From 4ab68fe2a89809630abd8da5d55605351764fe21 Mon Sep 17 00:00:00 2001 From: mysticbbs Date: Mon, 13 Feb 2012 19:53:02 -0500 Subject: [PATCH] Initial import --- mystic/mis_ansiwfc.pas | 42 + mystic/mis_client_ftp.pas | 827 +++++++++++++ mystic/mis_client_http.pas | 141 +++ mystic/mis_client_nntp.pas | 146 +++ mystic/mis_client_pop3.pas | 497 ++++++++ mystic/mis_client_smtp.pas | 329 ++++++ mystic/mis_client_telnet.pas | 135 +++ mystic/mis_common.pas | 241 ++++ mystic/mis_nodedata.pas | 115 ++ mystic/mis_server.pas | 262 ++++ mystic/mkcrap.pas | 305 +++++ mystic/mpl_common.pas | 365 ++++++ mystic/mpl_execute.pas | 2171 ++++++++++++++++++++++++++++++++++ mystic/mpl_fileio.pas | 156 +++ mystic/mpl_types.pas | 294 +++++ mystic/mplc.pas | 93 ++ mystic/mystpack.pas | 555 +++++++++ mystic/records.pas | 697 +++++++++++ 18 files changed, 7371 insertions(+) create mode 100644 mystic/mis_ansiwfc.pas create mode 100644 mystic/mis_client_ftp.pas create mode 100644 mystic/mis_client_http.pas create mode 100644 mystic/mis_client_nntp.pas create mode 100644 mystic/mis_client_pop3.pas create mode 100644 mystic/mis_client_smtp.pas create mode 100644 mystic/mis_client_telnet.pas create mode 100644 mystic/mis_common.pas create mode 100644 mystic/mis_nodedata.pas create mode 100644 mystic/mis_server.pas create mode 100644 mystic/mkcrap.pas create mode 100644 mystic/mpl_common.pas create mode 100644 mystic/mpl_execute.pas create mode 100644 mystic/mpl_fileio.pas create mode 100644 mystic/mpl_types.pas create mode 100644 mystic/mplc.pas create mode 100644 mystic/mystpack.pas create mode 100644 mystic/records.pas diff --git a/mystic/mis_ansiwfc.pas b/mystic/mis_ansiwfc.pas new file mode 100644 index 0000000..3c9906e --- /dev/null +++ b/mystic/mis_ansiwfc.pas @@ -0,0 +1,42 @@ +Procedure DrawStatusScreen; +Const + IMAGEDATA_WIDTH=80; + IMAGEDATA_DEPTH=25; + IMAGEDATA_LENGTH=518; + IMAGEDATA : array [1..518] of Char = ( + #1,#23,' ','M','y','s','t','i','c',' ','I','n','t','e','r','n','e', + 't',' ','S','e','r','v','e','r',#25,#30, #0,'t','e','l','n','e','t', + '/','s','m','t','p','/','p','o','p','3','/','f','t','p','/','n','n', + 't','p',' ',#24, #8,#16,#26,'O','°',#24,'°', #1,'Ú',' ', #7,'C','o', + 'n','n','e','c','t','i','o','n','s',' ', #1,#26,'%','Ä','¿', #8,'°', + #1,'Ú',' ', #7,'S','t','a','t','i','s','t','i','c','s',' ', #1,#26, + #9,'Ä','¿', #8,'°',#24,'°', #1,'³',#25,'2','³', #8,'°', #1,'³',#25, + #21,'³', #8,'°',#24,'°', #1,'³',#25,'2','³', #8,'°', #1,'³',#25, #5, + #7,'P','o','r','t', #8,':',#25,#10, #1,'³', #8,'°',#24,'°', #1,'³', + #25,'2','³', #8,'°', #1,'³',#25, #6, #7,'M','a','x', #8,':',#25,#10, + #1,'³', #8,'°',#24,'°', #1,'³',#25,'2','³', #8,'°', #1,'³',#25, #3, + #7,'A','c','t','i','v','e', #8,':',#25,#10, #1,'³', #8,'°',#24,'°', + #1,'³',#25,'2','³', #8,'°', #1,'³',#25, #2, #7,'B','l','o','c','k', + 'e','d', #8,':',#25,#10, #1,'³', #8,'°',#24,'°', #1,'³',#25,'2','³', + #8,'°', #1,'³',#25, #2, #7,'R','e','f','u','s','e','d', #8,':',#25, + #10, #1,'³', #8,'°',#24,'°', #1,'³',#25,'2','³', #8,'°', #1,'³',#25, + #4, #7,'T','o','t','a','l', #8,':',#25,#10, #1,'³', #8,'°',#24,'°', + #1,'³',#25,'2','³', #8,'°', #1,'³',#25,#21,'³', #8,'°',#24,'°', #1, + 'À',#26,'2','Ä','Ù', #8,'°', #1,'À',#26,#21,'Ä','Ù', #8,'°',#24,#26, + 'O','°',#24,'°', #1,'Ú',' ', #7,'S','e','r','v','e','r',' ','S','t', + 'a','t','u','s',' ', #1,#26,'<','Ä','¿', #8,'°',#24,'°', #1,'³',#25, + 'K','³', #8,'°',#24,'°', #1,'³',#25,'K','³', #8,'°',#24,'°', #1,'³', + #25,'K','³', #8,'°',#24,'°', #1,'³',#25,'K','³', #8,'°',#24,'°', #1, + '³',#25,'K','³', #8,'°',#24,'°', #1,'³',#25,'K','³', #8,'°',#24,'°', + #1,'³',#25,'K','³', #8,'°',#24,'°', #1,'³',#25,'K','³', #8,'°',#24, + '°', #1,'À',#26,'K','Ä','Ù', #8,'°',#24,#26,'O','°',#24,#23,' ', #1, + 'T','A','B','/','S','w','i','t','c','h',' ','W','i','n','d','o','w', + #25, #2,'E','N','T','E','R','/','S','n','o','o','p',#25, #2,'S','P', + 'A','C','E','/','L','o','c','a','l',#25, #2,'A','L','T','-','K','/', + 'K','i','l','l',' ','U','s','e','r',#25, #2,'E','S','C','/','S','h', + 'u','t','d','o','w','n',' ',#24); +Begin + Console.LoadScreenImage(ImageData, ImageData_Length, ImageData_Width, 1, 1); + Console.WriteXY (1, 25, 113, strPadC('SPACE/Local TELNET TAB/Switch ESC/Shutdown', 79, ' ')); +// Console.WriteXY (25, 1, 113, strPadC(mysVersionText, 30, ' ')); +End; diff --git a/mystic/mis_client_ftp.pas b/mystic/mis_client_ftp.pas new file mode 100644 index 0000000..0365daf --- /dev/null +++ b/mystic/mis_client_ftp.pas @@ -0,0 +1,827 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_FTP; + +// does not send file/directory datestamps +// does not support uploading (need to make bbs functions generic for this +// and for mbbsutil -fupload command) + +Interface + +Uses + SysUtils, + m_Strings, + m_FileIO, + m_Socket_Class, + m_DateTime, + MIS_Server, + MIS_NodeData, + MIS_Common; + +Function CreateFTP (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; + +Type + TFTPServer = Class(TServerClient) + Server : TServerManager; + UserName : String[40]; + Password : String[20]; + LoggedIn : Boolean; + GotQuit : Boolean; + IsPassive : Boolean; + InTransfer : Boolean; + Cmd : String; + Data : String; + DataPort : Word; + DataIP : String; + DataSocket : TSocketClass; + User : RecUser; + UserPos : LongInt; + FBasePos : LongInt; + FBase : FBaseRec; + SecLevel : RecSecurity; + FileMask : String; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + +// Procedure dlog (S:String); + + Procedure ResetSession; + Procedure UpdateUserStats (TFBase: FBaseRec; FDir: FDirRec; DirPos: LongInt); + Function CheckFileLimits (TempFBase: FBaseRec; FDir: FDirRec) : Byte; + Function OpenDataSession : Boolean; + Procedure CloseDataSession; + Function ValidDirectory (TempBase: FBaseRec) : Boolean; + Function FindDirectory (Var TempBase: FBaseRec) : LongInt; + + Procedure cmdUSER; + Procedure cmdPASS; + Procedure cmdREIN; + Procedure cmdPORT; + Procedure cmdPASV; + Procedure cmdCWD; + Procedure cmdCDUP; + Procedure cmdNLST; + Procedure cmdLIST; + Procedure cmdPWD; + Procedure cmdRETR; + Procedure cmdSTRU; + Procedure cmdMODE; + Procedure cmdSYST; + Procedure cmdTYPE; + Procedure cmdEPRT; + Procedure cmdEPSV; + Procedure cmdSIZE; + End; + +Implementation + +Const + FTPTimeOut = 120; // Make this configurabe in MCFG? + FileBufSize = 8 * 1024; + + re_DataOpen = '125 Data connection already open'; + re_DataOpening = '150 File status okay; about to open data connection.'; + re_CommandOK = '200 Command okay.'; + re_NoCommand = '202 Command not implemented, superfluous at this site.'; + re_Greeting = '220 Mystic FTP server ready'; + re_Goodbye = '221 Goodbye'; + re_DataClosed = '226 Closing data connection.'; + re_XferOK = '226 Transfer OK'; + re_PassiveOK = '227 Entering Passive Mode '; + re_LoggedIn = '230 User logged in, proceed.'; + re_DirOkay = '257 Working directory is now '; + re_UserOkay = '331 User name okay, need password.'; + re_NoData = '425 Unable to open data connection'; + re_BadCommand = '503 Bad sequence of commands.'; + re_UserUnknown = '530 Not logged in.'; + re_BadPW = '530 Login or password incorrect'; + re_BadDir = '550 Directory change failed'; + re_BadFile = '550 File not found'; + re_NoAccess = '550 Access denied'; + re_DLLimit = '550 Download limit would be exceeded'; + re_DLRatio = '550 Download/upload ratio would be exceeded'; + +Function CreateFTP (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TFTPServer.Create(Owner, CliSock); +End; + +Constructor TFTPServer.Create (Owner: TServerManager; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Server := Owner; +End; + +(* +Procedure TFTPServer.dlog (S:String); +Var + T : Text; +Begin + Assign (T, 'd:\code\mystic1\misftp.log'); + Append (T); + If IoResult <> 0 Then Rewrite(T); + WriteLn(T, S); + Close(T); +End; +*) + +Procedure TFTPServer.ResetSession; +Begin + If Assigned(DataSocket) Then DataSocket.Free; + + LoggedIn := False; + GotQuit := False; + UserName := ''; + Password := ''; + UserPos := -1; + DataIP := ''; + DataPort := 20; + DataSocket := NIL; + IsPassive := False; + FBasePos := -1; + InTransfer := False; +End; + +Procedure TFTPServer.UpdateUserStats (TFBase: FBaseRec; FDir: FDirRec; DirPos: LongInt); +Var + HistFile: File of HistoryRec; + History : HistoryRec; + FDirFile: File of FDirRec; + UserFile: File of RecUser; +Begin + Inc (FDir.DLs); + + Assign (UserFile, bbsConfig.DataPath + 'users.dat'); + ioReset (UserFile, SizeOf(RecUser), fmReadWrite + fmDenyWrite); + ioSeek (UserFile, UserPos - 1); + ioRead (UserFile, User); + + If DateDos2Str(User.LastOn, 1) <> DateDos2Str(CurDateDos, 1) Then Begin + User.CallsToday := 0; + User.DLsToday := 0; + User.DLkToday := 0; + User.TimeLeft := SecLevel.Time + End; + + // need to check if it were an upload and do things accordingly + + Inc (User.DLs); + Inc (User.DLsToday); + Inc (User.DLk, FDir.Size DIV 1024); + Inc (User.DLkToday, FDir.Size DIV 1024); + + ioSeek (UserFile, UserPos - 1); + ioWrite (UserFile, User); + Close (UserFile); + + Assign (FDirFile, bbsConfig.DataPath + TFBase.FileName + '.dir'); + ioReset (FDirFile, SizeOf(FDirRec), fmReadWrite + fmDenyWrite); + ioSeek (FDirFile, DirPos - 1); + ioWrite (FDirFile, FDir); + Close (FDirFile); + + Assign (HistFile, bbsConfig.DataPath + 'history.dat'); + ioReset (HistFile, SizeOf(HistoryRec), fmReadWrite + fmDenyWrite); + + If IoResult <> 0 Then ReWrite(HistFile); + + History.Date := CurDateDos; + + While Not Eof(HistFile) Do Begin + ioRead (HistFile, History); + + If DateDos2Str(History.Date, 1) = DateDos2Str(CurDateDos, 1) Then Begin + ioSeek (HistFile, FilePos(HistFile) - 1); + Break; + End; + End; + + If Eof(HistFile) Then Begin + FillChar(History, SizeOf(History), 0); + History.Date := CurDateDos; + End; + + Inc (History.Downloads, 1); + Inc (History.DownloadKB, FDir.Size DIV 1024); + + ioWrite (HistFile, History); + Close (HistFile); +End; + +Function TFTPServer.CheckFileLimits (TempFBase: FBaseRec; FDir: FDirRec) : Byte; +{ 0 = OK to download } +{ 1 = Offline or Invalid or Failed or NO ACCESS or no file (prompt 224)} +{ 2 = DL per day limit exceeded (prompt 58) } +{ 3 = UL/DL file ratio bad (prompt 211) } +Begin + Result := 1; + + If Not FileExist(TempFBase.Path + FDir.Filename) Then Exit; + + If Not CheckAccess(User, True, TempFBase.DLACS) Then Exit; + + If FDir.Flags And FDirOffline <> 0 Then Exit; + + If (FDir.Flags And FDirInvalid <> 0) And Not CheckAccess(User, True, bbsConfig.AcsDLUnvalid) Then Exit; + If (FDir.Flags And FDirFailed <> 0) And Not CheckAccess(User, True, bbsConfig.AcsDLFailed) Then Exit; + + If (FDir.Flags And FDirFree <> 0) or (User.Flags and UserNoRatio <> 0) or (TempFBase.IsFREE) Then Begin + Result := 0; + Exit; + End; + + If (User.DLsToday + 1 > SecLevel.MaxDLs) and (SecLevel.MaxDLs > 0) Then Begin + Result := 2; + Exit; + End; + + If SecLevel.DLRatio > 0 Then + If (User.ULs * SecLevel.DLRatio) <= (User.DLs + 1) Then Begin + Result := 3; + Exit; + End; + + If SecLevel.DLKRatio > 0 Then + If (User.ULk * SecLevel.DLkRatio) <= (User.DLk + (FDir.Size DIV 1024)) Then Begin + Result := 3; + Exit; + End; + + If (User.DLkToday + (FDir.Size DIV 1024) > SecLevel.MaxDLk) and (SecLevel.MaxDLk > 0) Then Begin + Result := 2; + Exit; + End; + + Result := 0; +End; + +Function TFTPServer.OpenDataSession : Boolean; +Var + WaitSock : TSocketClass; +Begin + Result := False; + + If DataSocket <> NIL Then Begin + Client.WriteLine(re_DataOpen); + Result := True; + Exit; + End; + + Client.WriteLine(re_DataOpening); + + If IsPassive Then Begin + WaitSock := TSocketClass.Create; + + WaitSock.WaitInit(DataPort); + + DataSocket := WaitSock.WaitConnection; + + If Not Assigned(DataSocket) Then Begin + WaitSock.Free; + Client.WriteLine(re_NoData); + Exit; + End; + + WaitSock.Free; + End Else Begin + DataSocket := TSocketClass.Create; + + If Not DataSocket.Connect(DataIP, DataPort) Then Begin + Client.WriteLine(re_NoData); + DataSocket.Free; + DataSocket := NIL; + Exit; + End; + End; + + Result := True; +End; + +Procedure TFTPServer.CloseDataSession; +Begin + If DataSocket <> NIL Then Begin + Client.WriteLine(re_DataClosed); + DataSocket.Free; + DataSocket := NIL; + End; +End; + +Function TFTPServer.ValidDirectory (TempBase: FBaseRec) : Boolean; +Begin + Result := CheckAccess(User, True, TempBase.FtpACS) and (TempBase.FtpName <> ''); +End; + +Function TFTPServer.FindDirectory (Var TempBase: FBaseRec) : LongInt; +Var + FBaseFile : TBufFile; + Found : Boolean; +Begin + Result := FBasePos; + TempBase := FBase; + FileMask := '*.*'; + + If Not LoggedIn Then Exit; + If Data = '' Then Exit; + + If (Pos('*', Data) > 0) or (Pos('.', Data) > 0) Then Begin + FileMask := JustFile(Data); + Data := JustPath(Data); + End; + + If Data = '/' Then Begin + Result := -1; + Exit; + End; + + If ((Data[1] = '/') or (Data[1] = '\')) Then Delete(Data, 1, 1); + If ((Data[Length(Data)] = '/') or (Data[Length(Data)] = '\')) Then Delete(Data, Length(Data), 1); + + If Data = '' Then Exit; + + FBaseFile := TBufFile.Create(FileBufSize); + + If FBaseFile.Open(bbsConfig.DataPath + 'fbases.dat', fmOpen, fmRWDN, SizeOf(FBaseRec)) Then Begin + Found := False; + + While Not FBaseFile.EOF Do Begin + FBaseFile.Read(TempBase); + + If (strUpper(TempBase.FtpName) = strUpper(Data)) and ValidDirectory(TempBase) Then Begin + Result := FBaseFile.FilePos; + Found := True; + Break; + End; + End; + End; + + FBaseFile.Free; + + If Not Found Then Begin + If Pos('-', Data) > 0 Then + FileMask := '*.*' + Else + FileMask := Data; + + TempBase := FBase; + Result := FBasePos; + End; +End; + +Procedure TFTPServer.cmdUSER; +Begin + ResetSession; + + If SearchForUser(Data, User, UserPos) Then Begin + Client.WriteLine(re_UserOkay); + UserName := Data; + End Else + Client.WriteLine(re_UserUnknown); +End; + +Procedure TFTPServer.cmdPASS; +Begin + If (UserName = '') or (UserPos = -1) Then Begin + Client.WriteLine(re_BadCommand); + Exit; + End; + + If strUpper(Data) = User.Password Then Begin + LoggedIn := True; + + Client.WriteLine(re_LoggedIn); + + GetSecurityLevel(User.Security, SecLevel); + + Server.Server.Status (User.Handle + ' logged in'); + End Else + Client.WriteLine(re_BadPW); +End; + +Procedure TFTPServer.cmdREIN; +Begin + ResetSession; + Client.WriteLine(re_Greeting); +End; + +Procedure TFTPServer.cmdPORT; +Var + Count : Byte; +Begin + If LoggedIn Then Begin + For Count := 1 to 3 Do + Data[Pos(',', Data)] := '.'; + + DataIP := Copy(Data, 1, Pos(',', Data) - 1); + + Delete (Data, 1, Pos(',', Data)); + + WordRec(DataPort).Hi := strS2I(Copy(Data, 1, Pos(',', Data) - 1)); + WordRec(DataPort).Lo := strS2I(Copy(Data, Pos(',', Data) + 1, Length(Data))); + + Client.WriteLine(re_CommandOK); + + IsPassive := False; + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdPASV; +Var + WaitSock : TSocketClass; +Begin + If LoggedIn Then Begin + DataPort := Random(65535-60000) + 60000; // make configurable?! + + Client.WriteLine(re_PassiveOK + '(' + strReplace(Client.HostIP, '.', ',') + ',' + strI2S(WordRec(DataPort).Hi) + ',' + strI2S(WordRec(DataPort).Lo) + ').'); + + IsPassive := True; + + WaitSock := TSocketClass.Create; + + WaitSock.WaitInit(DataPort); + + DataSocket := WaitSock.WaitConnection; + + If Not Assigned(DataSocket) Then Begin + WaitSock.Free; + Client.WriteLine(re_NoData); + Exit; + End; + + WaitSock.Free; + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdCDUP; +Begin + Client.WriteLine(re_DirOkay + '"/"'); + + FBasePos := -1; +End; + +Procedure TFTPServer.cmdCWD; +Var + TempBase : FBaseRec; + TempPos : LongInt; +Begin + If LoggedIn Then Begin + If (Data = '/') or (Copy(Data, 1, 2) = '..') Then Begin + FBasePos := -1; + Client.WriteLine(re_DirOkay + '"/"'); + Exit; + End; + + TempPos := FindDirectory(TempBase); + + If TempPos = -1 Then Begin + Client.WriteLine(re_BadDir); + Exit; + End; + + Client.WriteLine(re_DirOkay + '"/' + TempBase.FtpName + '"'); + + FBase := TempBase; + FBasePos := TempPos; + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdNLST; +Var + TempBase : FBaseRec; + TempPos : LongInt; + DirFile : TBufFile; + Dir : FDirRec; +Begin + If LoggedIn Then Begin + TempPos := FindDirectory(TempBase); + + If TempPos = -1 Then Begin + OpenDataSession; + CloseDataSession; + // list files in root directory, so show nothing + Exit; + End; + + OpenDataSession; + + DirFile := TBufFile.Create(FileBufSize); + + If DirFile.Open(bbsConfig.DataPath + TempBase.FileName + '.dir', fmOpenCreate, fmRWDN, SizeOf(FDirRec)) Then Begin + While Not DirFile.EOF Do Begin + DirFile.Read(Dir); + + If (Dir.Flags And FDirDeleted <> 0) Then Continue; + If (Dir.Flags And FDirInvalid <> 0) And (Not CheckAccess(User, True, bbsConfig.AcsSeeUnvalid)) Then Continue; + If (Dir.Flags And FDirFailed <> 0) And (Not CheckAccess(User, True, bbsConfig.AcsSeeFailed)) Then Continue; + + If WildcardMatch(FileMask, Dir.FileName) Then + DataSocket.WriteLine(Dir.FileName); + End; + End; + + DirFile.Free; + + CloseDataSession; + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdPWD; +Begin + If LoggedIn Then Begin + If FBasePos = -1 Then + Client.WriteLine(re_DirOkay + '"/"') + Else + Client.WriteLine(re_DirOkay + '"/' + FBase.FtpName + '"'); + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdLIST; +Var + TempBase : FBaseRec; + TempPos : LongInt; + FBaseFile : TBufFile; + DirFile : TBufFile; + Dir : FDirRec; +Begin + If LoggedIn Then Begin + TempPos := FindDirectory(TempBase); + + If TempPos = -1 Then Begin + OpenDataSession; + + FBaseFile := TBufFile.Create(FileBufSize); + + If FBaseFile.Open(bbsConfig.DataPath + 'fbases.dat', fmOpen, fmRWDN, SizeOf(FBaseRec)) Then Begin + While Not FBaseFile.EOF Do Begin + FBaseFile.Read(TempBase); + + If ValidDirectory(TempBase) and WildcardMatch(FileMask, TempBase.FtpName) Then + DataSocket.WriteLine('drwxr-xr-x 1 ftp ftp 0 Jul 11 23:35 ' + TempBase.FtpName) + End; + End; + + FBaseFile.Free; + + CloseDataSession; + + Exit; + End; + + OpenDataSession; + + DirFile := TBufFile.Create(FileBufSize); + + If DirFile.Open(bbsConfig.DataPath + TempBase.FileName + '.dir', fmOpenCreate, fmRWDN, SizeOf(FDirRec)) Then Begin + While Not DirFile.EOF Do Begin + DirFile.Read(Dir); + + If (Dir.Flags And FDirDeleted <> 0) Then Continue; + If (Dir.Flags And FDirInvalid <> 0) And (Not CheckAccess(User, True, bbsConfig.AcsSeeUnvalid)) Then Continue; + If (Dir.Flags And FDirFailed <> 0) And (Not CheckAccess(User, True, bbsConfig.AcsSeeFailed)) Then Continue; + + If WildcardMatch(FileMask, Dir.FileName) Then + DataSocket.WriteLine('-rw-r--r-- 1 ftp ftp ' + strPadL(strI2S(Dir.Size), 13, ' ') + ' Jul 11 23:35 ' + Dir.FileName) + End; + End; + + DirFile.Free; + + CloseDataSession; + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdRETR; +Var + TempPos : LongInt; + TempBase : FBaseRec; + DirFile : TBufFile; + Dir : FDirRec; + Found : LongInt; + F : File; + Buf : Array[1..4096] of Byte; + Tmp : LongInt; + Res : LongInt; +Begin + If LoggedIn Then Begin + TempPos := FindDirectory(TempBase); + + If TempPos = -1 Then Begin + Client.WriteLine(re_BadFile); + Exit; + End; + + DirFile := TBufFile.Create(FileBufSize); + Found := -1; + + If DirFile.Open(bbsConfig.DataPath + TempBase.FileName + '.dir', fmOpenCreate, fmRWDN, SizeOf(FDirRec)) Then Begin + While Not DirFile.EOF Do Begin + DirFile.Read(Dir); + + If WildcardMatch(FileMask, Dir.FileName) Then Begin + Found := DirFile.FilePos; + Break; + End; + End; + + DirFile.Free; + + If Found = -1 Then Begin + Client.WriteLine(re_BadFile); + Exit; + End; + + Case CheckFileLimits(TempBase, Dir) of + 0 : Begin + Assign (F, TempBase.Path + Dir.FileName); + ioReset (F, 1, fmRWDN); + + InTransfer := True; + + OpenDataSession; + + While Not Eof(F) Do Begin + BlockRead (F, Buf, SizeOf(Buf), Res); + + Repeat + Tmp := DataSocket.WriteBuf(Buf, Res); + Dec (Res, Tmp); + Until Res = 0; + End; + + Close (F); + + Client.WriteLine (re_XferOK); + + CloseDataSession; + + InTransfer := False; + + UpdateUserStats(TempBase, Dir, Found); + End; + 1 : Client.WriteLine(re_NoAccess); + 2 : Client.WriteLine(re_DLLimit); + 3 : Client.WriteLine(re_DLRatio); + End; + End Else + Client.WriteLine(re_BadFile); + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdSTRU; +Begin + If strUpper(Data) = 'F' Then + Client.WriteLine('200 FILE structure.') + Else + Client.WriteLine('504 Only FILE structure supported.'); +End; + +Procedure TFTPServer.cmdMODE; +Begin + If strUpper(Data) = 'S' Then + Client.WriteLine('200 STREAM mode.') + Else + Client.WriteLine('504 Only STREAM mode supported.'); +End; + +Procedure TFTPServer.cmdSYST; +Begin + Client.WriteLine('215 UNIX Type: L8'); +End; + +Procedure TFTPServer.cmdTYPE; +Begin + Client.WriteLine('200 All files sent in BINARY mode.'); +End; + +Procedure TFTPServer.cmdEPRT; +Var + DataType : String; +Begin + If LoggedIn Then Begin + DataType := strWordGet(1, Data, '|'); + + If DataType = '1' Then Begin + DataIP := strWordGet(2, Data, '|'); + DataPort := strS2I(strWordGet(3, Data, '|')); + IsPassive := False; + + Client.WriteLine(re_CommandOK); + End Else + Client.WriteLine('522 Network protocol not supported, use (1)'); + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdEPSV; +Var + WaitSock : TSocketClass; +Begin + If LoggedIn Then Begin + If Data = '' Then Begin + DataPort := Random(65535 - 60000) + 60000; // make configuratable + IsPassive := True; + + Client.WriteLine('229 Entering Extended Passive Mode (|||' + strI2S(DataPort) + '|)'); + + WaitSock := TSocketClass.Create; + + WaitSock.WaitInit(DataPort); + + DataSocket := WaitSock.WaitConnection; + + If Not Assigned(DataSocket) Then Begin + WaitSock.Free; + Client.WriteLine(re_NoData); + Exit; + End; + + WaitSock.Free; + End Else + If Data = '1' Then + Client.WriteLine(re_CommandOK) + Else + Client.WriteLine('522 Network protocol not supported, use (1)'); + + End Else + Client.WriteLine(re_BadCommand); +End; + +Procedure TFTPServer.cmdSIZE; +Begin + Client.WriteLine('550 Not implemented'); +End; + +Procedure TFTPServer.Execute; +Var + Str : String; +Begin + cmdREIN; + + Repeat + If Client.WaitForData(FTPTimeOut * 1000) = 0 Then Break; + + If Terminated Then Exit; + + If Client.ReadLine(Str) = -1 Then Exit; + +// dlog(Str); +//server.server.status(str); + + Cmd := strUpper(strWordGet(1, Str, ' ')); + + If Pos(' ', Str) > 0 Then + Data := strStripB(Copy(Str, Pos(' ', Str) + 1, Length(Str)), ' ') + Else + Data := ''; + + If Cmd = 'CDUP' Then cmdCDUP Else + If Cmd = 'CWD' Then cmdCWD Else + If Cmd = 'EPRT' Then cmdEPRT Else + If Cmd = 'EPSV' Then cmdEPSV Else + If Cmd = 'LIST' Then cmdLIST Else + If Cmd = 'MODE' Then cmdMODE Else + If Cmd = 'NLST' Then cmdNLST Else + If Cmd = 'NOOP' Then Client.WriteLine(re_CommandOK) Else + If Cmd = 'PASS' Then cmdPASS Else + If Cmd = 'PASV' Then cmdPASV Else + If Cmd = 'PORT' Then cmdPORT Else + If Cmd = 'PWD' Then cmdPWD ELse + If Cmd = 'REIN' Then cmdREIN Else + If Cmd = 'RETR' Then cmdRETR Else + If Cmd = 'SIZE' Then cmdSIZE Else + If Cmd = 'STRU' Then cmdSTRU Else + If Cmd = 'SYST' Then cmdSYST Else + If Cmd = 'TYPE' Then cmdTYPE Else + If Cmd = 'USER' Then cmdUSER Else + If Cmd = 'XPWD' Then cmdPWD Else + If Cmd = 'QUIT' Then Begin + GotQuit := True; + Break; + End Else + Client.WriteLine(re_NoCommand); + Until Terminated; + + If GotQuit Then Begin + Client.WriteLine(re_Goodbye); + + Server.Server.Status (User.Handle + ' logged out'); + End; +End; + +Destructor TFTPServer.Destroy; +Begin + If Assigned(DataSocket) Then DataSocket.Free; + + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_client_http.pas b/mystic/mis_client_http.pas new file mode 100644 index 0000000..226267e --- /dev/null +++ b/mystic/mis_client_http.pas @@ -0,0 +1,141 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_POP3; + +Interface + +Uses + SysUtils, + m_Strings, + m_FileIO, + m_Socket_Class, + m_DateTime, + MIS_Server, + MIS_NodeData, + MIS_Common; + +Function CreatePOP3 (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass) : TServerClient; + +Type + TPOP3Server = Class(TServerClient) + Server : TServerManager; + UserName : String[40]; + Password : String[20]; + LoggedIn : Boolean; + Cmd : String; + Data : String; + User : UserRec; + UserPos : LongInt; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + + Procedure ResetSession; + + Procedure cmdUSER; + Procedure cmdPASS; + End; + +Implementation + +Const + POP3TimeOut = 120; + FileBufSize = 8 * 1024; + + re_OK = '+OK '; + re_Error = '-ERR '; + + re_UnknownCommand = re_Error + 'Unknown command'; + re_UnknownUser = re_Error + 'Unknown user'; + re_BadLogin = re_Error + 'Bad credentials'; + + re_Greeting = 'Mystic POP3 Server'; + re_Goodbye = re_OK + 'Goodbye'; + re_SendUserPass = re_OK + 'Send user password'; + re_LoggedIn = re_OK + 'Welcome'; + +Function CreatePOP3 (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TPOP3Server.Create(Owner, CliSock); +End; + +Constructor TPOP3Server.Create (Owner: TServerManager; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Server := Owner; +End; + +Procedure TPOP3Server.ResetSession; +Begin + LoggedIn := False; + UserName := ''; + Password := ''; + UserPos := -1; +End; + +Procedure TPOP3Server.cmdUSER; +Begin + ResetSession; + + If SearchForUser(Data, User, UserPos) Then Begin + Client.WriteLine(re_SendUserPass); + UserName := Data; + End Else + Client.WriteLine(re_UnknownUser); +End; + +Procedure TPOP3Server.cmdPASS; +Begin + If (UserName = '') or (UserPos = -1) Then Begin + Client.WriteLine(re_UnknownUser); + Exit; + End; + + If strUpper(Data) = User.Password Then Begin + LoggedIn := True; + + Client.WriteLine(re_LoggedIn); + End Else + Client.WriteLine(re_BadLogin); +End; + +Procedure TPOP3Server.Execute; +Var + Str : String; +Begin + ResetSession; + Client.WriteLine(re_Greeting); + + Repeat + If Client.WaitForData(POP3TimeOut * 1000) = 0 Then Break; + + If Terminated Then Exit; + + If Client.ReadLine(Str) = -1 Then Exit; + +server.server.status(str); + + Cmd := strUpper(strWordGet(1, Str, ' ')); + + If Pos(' ', Str) > 0 Then + Data := strStripB(Copy(Str, Pos(' ', Str) + 1, Length(Str)), ' ') + Else + Data := ''; + + If Cmd = 'PASS' Then cmdPASS Else + If Cmd = 'QUIT' Then Break Else + If Cmd = 'USER' Then cmdUSER Else + Client.WriteLine(re_UnknownCommand); + Until Terminated; + + If Not Terminated Then Client.WriteLine(re_Goodbye); +End; + +Destructor TPOP3Server.Destroy; +Begin + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_client_nntp.pas b/mystic/mis_client_nntp.pas new file mode 100644 index 0000000..9068da9 --- /dev/null +++ b/mystic/mis_client_nntp.pas @@ -0,0 +1,146 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_NNTP; + +// lookup: +// how to send greeting and goodbye? +// how to send capabilities so far only AUTHINFO +// determine base feature-set required + +Interface + +Uses + SysUtils, + m_Strings, + m_FileIO, + m_Socket_Class, + m_DateTime, + MIS_Server, + MIS_NodeData, + MIS_Common; + +Function CreateNNTP (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass) : TServerClient; + +Type + TNNTPServer = Class(TServerClient) + Server : TServerManager; + UserName : String[40]; + Password : String[20]; + LoggedIn : Boolean; + Cmd : String; + Data : String; + User : RecUser; + UserPos : LongInt; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + + Procedure ResetSession; + + Procedure cmd_AUTHINFO; + End; + +Implementation + +Const + NNTPTimeOut = 180; // make configurable + + re_Greeting = 'Mystic BBS NNTP Server'; + re_Goodbye = 'Goodbye'; + + re_AuthOK = '281 Authentication accepted'; + re_AuthBad = '381 Authentication rejected'; + re_AuthPass = '381 Password required'; + re_AuthSync = '482 Bad Authentication sequence'; + re_Unknown = '500 Unknown command'; + re_UnknownOption = '501 Unknown option'; + +Function CreateNNTP (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TNNTPServer.Create(Owner, CliSock); +End; + +Constructor TNNTPServer.Create (Owner: TServerManager; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Server := Owner; +End; + +Procedure TNNTPServer.ResetSession; +Begin + LoggedIn := False; + UserName := ''; + Password := ''; + UserPos := -1; +End; + +Procedure TNNTPServer.cmd_AUTHINFO; +Var + NewCmd : String; + NewData : String; +Begin + ResetSession; + + NewCmd := strWordGet(1, Data, ' '); + NewData := Copy(Data, Pos(' ', Data) + 1, 255); + + If NewCmd = 'USER' Then Begin + If SearchForUser(NewData, User, UserPos) Then Begin + Client.WriteLine(re_AuthPass); + UserName := NewData; + End Else + Client.WriteLine(re_AuthBad); + End Else + If NewCmd = 'PASS' Then Begin + If UserPos = -1 Then + Client.WriteLine(re_AuthSync) + Else + If strUpper(NewData) = User.Password Then Begin + Client.WriteLine(re_AuthOK); + LoggedIn := True; + End Else + Client.WriteLine(re_AuthBad); + End Else + Client.WriteLine(re_UnknownOption); +End; + +Procedure TNNTPServer.Execute; +Var + Str : String; +Begin + ResetSession; + + Client.WriteLine(re_Greeting); + + Repeat + If Client.WaitForData(NNTPTimeOut * 1000) = 0 Then Break; + + If Terminated Then Exit; + + If Client.ReadLine(Str) = -1 Then Exit; + + //server.server.status(str); + + Cmd := strUpper(strWordGet(1, Str, ' ')); + + If Pos(' ', Str) > 0 Then + Data := strStripB(Copy(Str, Pos(' ', Str) + 1, Length(Str)), ' ') + Else + Data := ''; + + If Cmd = 'AUTHINFO' Then cmd_AUTHINFO Else + If Cmd = 'QUIT' Then Break Else + Client.WriteLine(re_Unknown); + Until Terminated; + + If Not Terminated Then Client.WriteLine(re_Goodbye); +End; + +Destructor TNNTPServer.Destroy; +Begin + Inherited Destroy; +End; + +End. \ No newline at end of file diff --git a/mystic/mis_client_pop3.pas b/mystic/mis_client_pop3.pas new file mode 100644 index 0000000..ba4053a --- /dev/null +++ b/mystic/mis_client_pop3.pas @@ -0,0 +1,497 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_POP3; + +// RFC 1939 +// optional TOP and APOP not implemented +// needs to reformat long messages > 79 chars? + +Interface + +Uses + MD5, + Classes, + SysUtils, + m_Strings, + m_FileIO, + m_Socket_Class, + m_DateTime, + MIS_Server, + MIS_NodeData, + MIS_Common, + BBS_MsgBase_ABS, + BBS_MsgBase_JAM, + BBS_MsgBase_Squish; + +Function CreatePOP3 (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; + +Const + MaxMailBoxSize = 1000; + +Type + PMailMessageRec = ^TMailMessageRec; + TMailMessageRec = Record + MsgSize : LongInt; + MD5 : String[32]; + Deleted : Boolean; + GotRETR : Boolean; + Text : TStringList; + End; + + TPOP3Server = Class(TServerClient) + Server : TServerManager; + UserName : String[40]; + Password : String[20]; + LoggedIn : Boolean; + GotQuit : Boolean; + Cmd : String; + Data : String; + User : RecUser; + UserPos : LongInt; + MailInfo : Array[1..MaxMailBoxSize] of PMailMessageRec; + MailSize : LongInt; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + + Procedure ResetSession; + Procedure CreateMailBoxData; + Procedure DeleteMessages; + Function GetMessageUID (Var MsgBase: PMsgBaseABS) : String; + Procedure GetMessageCount (Var TotalMsg: LongInt; Var TotalSize: LongInt); + + Procedure cmdLIST; + Procedure cmdUSER; + Procedure cmdPASS; + Procedure cmdSTAT; + Procedure cmdUIDL; + Procedure cmdRETR; + Procedure cmdRSET; + Procedure cmdDELE; + Procedure cmdTOP; + End; + +Implementation + +Const + POP3TimeOut : SmallInt = 900; { MCFG? } + DeleteOnRETR : Boolean = False; { MCFG? } + + re_OK = '+OK '; + re_Error = '-ERR '; + + re_UnknownCommand = re_Error + 'Unknown command'; + re_UnknownUser = re_Error + 'Unknown user'; + re_BadLogin = re_Error + 'Bad credentials'; + re_NotLoggedIn = re_Error + 'Not logged in'; + re_UnknownMail = re_Error + 'Unknown message'; + + re_Greeting = re_OK + 'Mystic POP3 Server'; + re_Goodbye = re_OK + 'Goodbye'; + re_SendUserPass = re_OK + 'Send user password'; + re_LoggedIn = re_OK + 'Welcome'; + re_GetMessage = re_OK + 'Sending message '; + re_ResetOK = re_OK + 'Messages reset'; + re_MsgDeleted = re_OK + 'Message deleted'; + +Function CreatePOP3 (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TPOP3Server.Create(Owner, CliSock); +End; + +Constructor TPOP3Server.Create (Owner: TServerManager; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Server := Owner; + MailSize := 0; +End; + +Procedure TPOP3Server.ResetSession; +Var + Count : LongInt; +Begin + LoggedIn := False; + GotQuit := False; + UserName := ''; + Password := ''; + UserPos := -1; + + For Count := 1 to MailSize Do + If MailInfo[Count] <> NIL Then Begin + If Assigned(MailInfo[Count].Text) Then + MailInfo[Count].Text.Free; + + Dispose (MailInfo[Count]); + End; + + MailSize := 0; +End; + +Procedure TPOP3Server.GetMessageCount (Var TotalMsg: LongInt; Var TotalSize: LongInt); +Var + Count : LongInt; +Begin + TotalMsg := 0; + TotalSize := 0; + + For Count := 1 to MailSize Do + If Not MailInfo[Count].Deleted Then Begin + Inc (TotalMsg); + Inc (TotalSize, MailInfo[Count].MsgSize); + End; +End; + +Function TPOP3Server.GetMessageUID (Var MsgBase: PMsgBaseABS) : String; +Var + TempStr : String; +Begin + // FP might calc this wrong if we do it all at once, so annoying + + TempStr := strI2S(User.PermIdx); + TempStr := TempStr + MsgBase^.GetFrom; + TempStr := TempStr + MsgBase^.GetDate; + TempStr := TempStr + MsgBase^.GetTime; + + Result := MD5Print(MD5String(TempStr)); +End; + +Procedure TPOP3Server.CreateMailBoxData; +Var + MBaseFile : File of MBaseRec; + MBase : MBaseRec; + MsgBase : PMsgBaseABS; + + Function ParseDateTime (Date, Time : String) : String; + Begin + DateSeparator := '-'; + ParseDateTime := FormatDateTime('ddd, dd mmm yyyy hh:nn:ss', StrToDateTime(Date + ' ' + Time)); + End; + + Procedure AddLine (Str: String); + Begin + MailInfo[MailSize].Text.Add(Str); + + Inc (MailInfo[MailSize].MsgSize, Length(Str) + 2); {CRLF} + End; + +Begin + Assign (MBaseFile, bbsConfig.DataPath + 'mbases.dat'); + + If Not ioReset(MBaseFile, SizeOf(MBaseRec), fmRWDN) Then Exit; + + ioRead (MBaseFile, MBase); + Close (MBaseFile); + + Case MBase.BaseType of + 0 : MsgBase := New(PMsgBaseJAM, Init); + 1 : MsgBase := New(PMsgBaseSquish, Init); + End; + + MsgBase^.SetMsgPath (MBase.Path + MBase.FileName); + + If Not MsgBase^.OpenMsgBase Then Begin + Dispose (MsgBase, Done); + Exit; + End; + + MsgBase^.YoursFirst(User.RealName, User.Handle); + + While MsgBase^.YoursFound Do Begin + MsgBase^.MsgStartup; + MsgBase^.MsgTxtStartup; + + Inc (MailSize); + + New (MailInfo[MailSize]); + + MailInfo[MailSize].Text := TStringList.Create; + + AddLine ('Date: ' + ParseDateTime(MsgBase^.GetDate, MsgBase^.GetTime)); + AddLine ('From: ' + MsgBase^.GetFrom + ' <' + strReplace(MsgBase^.GetFrom, ' ', '_') + '@' + bbsConfig.inetDomain + '>'); + AddLine ('X-Mailer: Mystic BBS ' + mysVersion); + AddLine ('To: ' + MsgBase^.GetTo + ' <' + strReplace(MsgBase^.GetTo, ' ', '_') + '@' + bbsConfig.inetDomain + '>'); + AddLine ('Subject: ' + MsgBase^.GetSubj); + AddLine ('Content-Type: text/plain; charset=us-ascii'); + AddLine (''); + + While Not MsgBase^.EOM Do + AddLine(MsgBase^.GetString(79)); + + MailInfo[MailSize].MD5 := GetMessageUID(MsgBase); + MailInfo[MailSize].GotRETR := False; + MailInfo[MailSize].Deleted := False; + + MsgBase^.YoursNext; + End; + + MsgBase^.CloseMsgBase; + + Dispose (MsgBase, Done); +End; + +Procedure TPOP3Server.DeleteMessages; +Var + Count : LongInt; + MBaseFile : File of MBaseRec; + MBase : MBaseRec; + MsgBase : PMsgBaseABS; +Begin + Assign (MBaseFile, bbsConfig.DataPath + 'mbases.dat'); + + If Not ioReset(MBaseFile, SizeOf(MBaseRec), fmRWDN) Then Exit; + + ioRead (MBaseFile, MBase); + Close (MBaseFile); + + Case MBase.BaseType of + 0 : MsgBase := New(PMsgBaseJAM, Init); + 1 : MsgBase := New(PMsgBaseSquish, Init); + End; + + MsgBase^.SetMsgPath (MBase.Path + MBase.FileName); + + If Not MsgBase^.OpenMsgBase Then Begin + Dispose (MsgBase, Done); + Exit; + End; + + For Count := 1 to MailSize Do Begin + If MailInfo[Count].Deleted or (MailInfo[Count].GotRETR and DeleteOnRETR) Then Begin + MsgBase^.YoursFirst(User.RealName, User.Handle); + + While MsgBase^.YoursFound Do Begin + MsgBase^.MsgStartUp; + + If GetMessageUID(MsgBase) = MailInfo[Count].MD5 Then Begin + MsgBase^.DeleteMsg; + Break; + End; + + MsgBase^.YoursNext; + End; + End; + End; + + MsgBase^.CloseMsgBase; + + Dispose (MsgBase, Done); +End; + +Procedure TPOP3Server.cmdUSER; +Begin + ResetSession; + + If SearchForUser(Data, User, UserPos) Then Begin + Client.WriteLine(re_SendUserPass); + UserName := Data; + End Else + Client.WriteLine(re_UnknownUser); +End; + +Procedure TPOP3Server.cmdPASS; +Begin + If (UserName = '') or (UserPos = -1) Then Begin + Client.WriteLine(re_UnknownUser); + Exit; + End; + + If strUpper(Data) = User.Password Then Begin + LoggedIn := True; + + CreateMailboxData; + + Client.WriteLine(re_LoggedIn); + + Server.Server.Status(User.Handle + ' logged in'); + End Else + Client.WriteLine(re_BadLogin); +End; + +Procedure TPOP3Server.cmdSTAT; +Var + DataSize : LongInt; + DataMsg : LongInt; +Begin + If LoggedIn Then Begin + GetMessageCount(DataMsg, DataSize); + + Client.WriteLine(re_OK + strI2S(DataMsg) + ' ' + strI2O(Datasize)); + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdLIST; +Var + MsgNum : LongInt; + MsgSize : LongInt; + Count : LongInt; +Begin + If LoggedIn Then Begin + + If Data <> '' Then Begin + MsgNum := strS2I(Data); + + If (MsgNum > 0) and (MsgNum <= MailSize) and (Not MailInfo[MsgNum].Deleted) Then + Client.WriteLine(re_OK + strI2S(MsgNum) + ' ' + strI2O(MailInfo[MsgNum].MsgSize)) + Else + Client.WriteLine(re_UnknownMail); + End Else Begin + GetMessageCount(MsgNum, MsgSize); + + Client.WriteLine (re_OK + strI2S(MsgNum) + ' messages (' + strI2O(MsgSize) + ' octets)'); + + For Count := 1 to MailSize Do + If Not MailInfo[Count].Deleted Then + Client.WriteLine (strI2S(Count) + ' ' + strI2O(MailInfo[Count].MsgSize)); + + Client.WriteLine('.'); + End; + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdUIDL; +Var + MsgNum : LongInt; + Count : LongInt; +Begin + If LoggedIn Then Begin + If Data <> '' Then Begin + MsgNum := strS2I(Data); + + If (MsgNum > 0) and (MsgNum <= MailSize) and (Not MailInfo[MsgNum].Deleted) Then + Client.WriteLine(re_OK + strI2S(MsgNum) + ' ' + MailInfo[MsgNum].MD5) + Else + Client.WriteLine(re_UnknownMail); + End Else Begin + Client.WriteLine (re_OK + 'Message list follows'); + + For Count := 1 to MailSize Do + If Not MailInfo[Count].Deleted Then Begin + Client.WriteLine (strI2S(Count) + ' ' + MailInfo[Count].MD5); + End; + Client.WriteLine('.'); + End; + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdRETR; +Var + MsgNum : LongInt; + Count : LongInt; +Begin + If LoggedIn Then Begin + MsgNum := strS2I(Data); + + If (MsgNum > 0) and (MsgNum <= MailSize) and (Not MailInfo[MsgNum].Deleted) Then Begin + Client.WriteLine (re_GetMessage + strI2S(MsgNum)); + + For Count := 0 to MailInfo[MsgNum].Text.Count - 1 Do + Client.WriteLine(MailInfo[MsgNum].Text[Count]); + + Client.WriteLine('.'); + + MailInfo[MsgNum].GotRETR := True; + End Else + Client.WriteLine(re_UnknownMail); + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdRSET; +Var + Count : LongInt; +Begin + If LoggedIn Then Begin + For Count := 1 to MailSize Do + MailInfo[Count].Deleted := False; + + Client.WriteLine (re_ResetOK); + End Else + Client.WriteLine (re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdDELE; +Var + MsgNum : LongInt; +Begin + If LoggedIn Then Begin + MsgNum := strS2I(Data); + + If (MsgNum > 0) and (MsgNum <= MailSize) and (Not MailInfo[MsgNum].Deleted) Then Begin + MailInfo[MsgNum].Deleted := True; + + Client.WriteLine(re_MsgDeleted); + End Else + Client.WriteLine(re_UnknownMail); + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.cmdTOP; +Begin + If LoggedIn Then Begin + End Else + Client.WriteLine(re_NotLoggedIn); +End; + +Procedure TPOP3Server.Execute; +Var + Str : String; +Begin + ResetSession; + + Client.WriteLine(re_Greeting); + + Repeat + If Client.WaitForData(POP3TimeOut * 1000) = 0 Then Break; + + If Terminated Then Exit; + + If Client.ReadLine(Str) = -1 Then Exit; + + Cmd := strUpper(strWordGet(1, Str, ' ')); + + If Pos(' ', Str) > 0 Then + Data := strStripB(Copy(Str, Pos(' ', Str) + 1, Length(Str)), ' ') + Else + Data := ''; + +// If Cmd = 'APOP' Then cmdAPOP Else + If Cmd = 'DELE' Then cmdDELE Else + If Cmd = 'LIST' Then cmdLIST Else + If Cmd = 'NOOP' Then Client.WriteLine(re_OK) Else + If Cmd = 'PASS' Then cmdPASS Else + If Cmd = 'RETR' Then cmdRETR Else + If Cmd = 'RSET' Then cmdRSET Else + If Cmd = 'STAT' Then cmdSTAT Else +// If Cmd = 'TOP' Then cmdTOP Else + If Cmd = 'UIDL' Then cmdUIDL Else + If Cmd = 'USER' Then cmdUSER Else + If Cmd = 'QUIT' Then Begin + GotQuit := True; + Break; + End Else + Client.WriteLine(re_UnknownCommand); + Until Terminated; + + If GotQuit Then Begin + Client.WriteLine(re_Goodbye); + + Server.Server.Status (User.Handle + ' logged out'); + + DeleteMessages; + End; +End; + +Destructor TPOP3Server.Destroy; +Begin + ResetSession; + + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_client_smtp.pas b/mystic/mis_client_smtp.pas new file mode 100644 index 0000000..a688848 --- /dev/null +++ b/mystic/mis_client_smtp.pas @@ -0,0 +1,329 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_SMTP; + +{ update e-mails post stats } +{ update bbs history } + +Interface + +Uses + Classes, + SysUtils, + m_Strings, + m_FileIO, + m_Socket_Class, + m_DateTime, + bbs_MsgBase_ABS, + bbs_MsgBase_JAM, + bbs_MsgBase_Squish, + MIS_Server, + MIS_NodeData, + MIS_Common; + +Function CreateSMTP (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; + +Type + TSMTPServer = Class(TServerClient) + Server : TServerManager; + User : RecUser; + UserPos : LongInt; + Cmd : String; + Data : String; + EndSession : Boolean; + FromName : String; + FromPos : LongInt; + ToList : TStringList; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + + Procedure ResetSession; + Function ValidateNameAndDomain (IsFrom: Boolean) : Boolean; + + Procedure cmdHELO; + Procedure cmdRSET; + Procedure cmdMAIL; + Procedure cmdRCPT; + Procedure cmdDATA; + End; + +Implementation + +Const + SMTPTimeOut = 120; { MCFG } + SMTPHackThresh = 10000; + + re_Goodbye = '221 Goodbye'; + re_UnknownCmd = '502 Unknown command'; + re_OK = '250 OK'; + re_BadUser = '550 No such user here'; + re_NeedMail = '503 Must send MAIL FROM: first'; + re_NeedRcpt = '503 Must send RCPT TO: first'; + re_ErrorSending = '550 Mailbox not found'; + +Function CreateSMTP (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TSMTPServer.Create(Owner, CliSock); +End; + +Constructor TSMTPServer.Create (Owner: TServerManager; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Server := Owner; +End; + +Function TSMTPServer.ValidateNameAndDomain (IsFrom: Boolean) : Boolean; +Var + InName : String; + InDomain : String; +Begin + Result := False; + + InName := strReplace(Copy(Data, Pos('<', Data) + 1, Pos('@', Data) - Pos('<', Data) - 1), '_', ' '); + InDomain := Copy(Data, Pos('@', Data) + 1, Pos('>', Data) - Pos('@', Data) - 1); + + If IsFrom Then + Server.Server.Status('User: ' + InName + ' Domain: ' + InDomain); + + If InDomain <> bbsConfig.iNetDomain Then Begin + Server.Server.Status('Refused by domain: ' + InName + '@' + InDomain); + Exit; + End; + + Result := SearchForUser(InName, User, UserPos); + + If Not Result Then + Server.Server.Status('Refused by name: ' + InName + '@' + InDomain); +End; + +Procedure TSMTPServer.ResetSession; +Begin + UserPos := -1; + FromName := ''; + FromPos := -1; + EndSession := False; + + If Assigned(ToList) Then ToList.Free; + + ToList := TStringList.Create; +End; + +Procedure TSMTPServer.cmdHELO; +Begin + Client.WriteLine('250 ' + bbsConfig.inetDomain); +End; + +Procedure TSMTPServer.cmdRSET; +Begin + ResetSession; + + Client.WriteLine(re_OK); +End; + +Procedure TSMTPServer.cmdMAIL; +Begin + If ValidateNameAndDomain(True) Then Begin + FromName := User.Handle; + + Client.WriteLine (re_OK) + End Else + Client.WriteLine (re_BadUser); +End; + +Procedure TSMTPServer.cmdRCPT; +Begin + If FromName = '' Then Begin + Client.WriteLine (re_NeedMail); + Exit; + End; + + If ValidateNameAndDomain(False) Then Begin + ToList.Add(User.Handle); + + Client.WriteLine (re_OK); + End Else + Client.WriteLine (re_BadUser); +End; + +Procedure TSMTPServer.cmdDATA; +Var + InData : String; + HackCount : LongInt; + MBaseFile : File of MBaseRec; + MBase : MBaseRec; + MsgBase : PMsgBaseABS; + MsgText : TStringList; + MsgSubject : String; + MsgLoop : LongInt; + Count : LongInt; + Count2 : LongInt; + Str : String; +Begin + If FromName = '' Then Begin + Client.WriteLine (re_NeedMail); + Exit; + End; + + If ToList.Count = 0 Then Begin + Client.WriteLine (re_NeedRcpt); + Exit; + End; + + Client.WriteLine ('354 Start mail input; end with .'); + + MsgText := TStringList.Create; + + Repeat + Client.ReadLine(InData); + + If InData = '.' Then Break; + + If MsgText.Count >= mysMaxMsgLines Then Begin + HackCount := 0; + + While Not Terminated And (InData <> '.') Do Begin + // todo: what happens if they never send an EOL... could still flood + + Client.ReadLine(InData); + Inc (HackCount); + + If HackCount >= SMTPHackThresh Then Begin + EndSession := True; // someone is being a douchebag + Server.Server.Status('Flood attempt from ' + FromName + ' (' + Client.PeerIP + '); Goodbye'); + MsgText.Free; + Exit; + End; + End; + + Break; + End; + + MsgText.Add(InData); + Until False; + + Assign (MBaseFile, bbsConfig.DataPath + 'mbases.dat'); + ioReset (MBaseFile, SizeOf(MBaseRec), fmRWDN); + ioRead (MBaseFile, MBase); + Close (MBaseFile); + + Case MBase.BaseType of + 0 : MsgBase := New(PMsgBaseJAM, Init); + 1 : MsgBase := New(PMsgBaseSquish, Init); + End; + + MsgBase^.SetMsgPath (MBase.Path + MBase.FileName); + + If Not MsgBase^.OpenMsgBase Then + If Not MsgBase^.CreateMsgBase (MBase.MaxMsgs, MBase.MaxAge) Then Begin + Dispose(MsgBase, Done); + MsgText.Free; + Client.WriteLine(re_ErrorSending); + Exit; + End Else + If Not MsgBase^.OpenMsgBase Then Begin + Dispose(MsgBase, Done); + MsgText.Free; + Client.WriteLine(re_ErrorSending); + Exit; + End; + + MsgSubject := ''; + Count := 0; + + While Count < MsgText.Count Do Begin + If Pos('Subject:', MsgText.Strings[Count]) > 0 Then + MsgSubject := Copy(MsgText.Strings[Count], 10, Length(MsgText.Strings[Count])) + Else + If MsgText.Strings[Count] = '' Then Begin + While (MsgText.Strings[Count] = '') And (Count < MsgText.Count) Do Inc(Count); + Break; + End; + + Inc (Count); + End; + + If Count = MsgText.Count Then Begin + Client.WriteLine(re_ErrorSending); + MsgText.Free; + Exit; + End; + + For MsgLoop := 0 To ToList.Count - 1 Do Begin + Server.Server.Status('Sending mail from ' + FromName + ' to ' + ToList.Strings[MsgLoop]); + + MsgBase^.StartNewMsg; + + MsgBase^.SetLocal (True); + MsgBase^.SetMailType (mmtNormal); + MsgBase^.SetPriv (True); + MsgBase^.SetDate (FormatDateTime('mm/dd/yy', Now)); + MsgBase^.SetTime (FormatDateTime('hh:nn', Now)); + MsgBase^.SetFrom (FromName); + MsgBase^.SetTo (ToList.Strings[MsgLoop]); + MsgBase^.SetSubj (MsgSubject); + + For Count2 := Count to MsgText.Count - 1 Do Begin + Str := MsgText.Strings[Count2]; + + If Length(Str) > 79 Then Str[0] := #79; + + MsgBase^.DoStringLn(Str); + End; + + MsgBase^.WriteMsg; + End; + + MsgBase^.CloseMsgBase; + + Dispose (MsgBase, Done); + + Client.WriteLine(re_OK); +End; + +Procedure TSMTPServer.Execute; +Var + Str : String; +Begin + ResetSession; + + Client.WriteLine('220 ' + bbsConfig.iNetDomain + ' Mystic SMTP Ready'); + + Repeat + If Client.WaitForData(SMTPTimeOut * 1000) = 0 Then Break; + + If Terminated Then Exit; + + If Client.ReadLine(Str) = -1 Then Exit; + + Cmd := strUpper(strWordGet(1, Str, ' ')); + + If Pos(' ', Str) > 0 Then + Data := strStripB(Copy(Str, Pos(' ', Str) + 1, Length(Str)), ' ') + Else + Data := ''; + + If Cmd = 'DATA' Then cmdDATA Else + If Cmd = 'EHLO' Then cmdHELO Else + If Cmd = 'HELO' Then cmdHELO Else + If Cmd = 'MAIL' Then cmdMAIL Else + If Cmd = 'NOOP' Then Client.WriteLine(re_OK) Else + If Cmd = 'RCPT' Then cmdRCPT Else + If Cmd = 'RSET' Then cmdRSET Else + If Cmd = 'QUIT' Then Break Else + Client.WriteLine(re_UnknownCmd); + Until Terminated or EndSession; + + If Not Terminated And Not EndSession Then Client.WriteLine(re_Goodbye); +End; + +Destructor TSMTPServer.Destroy; +Begin + If Assigned(ToList) Then ToList.Free; + + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_client_telnet.pas b/mystic/mis_client_telnet.pas new file mode 100644 index 0000000..98c7e25 --- /dev/null +++ b/mystic/mis_client_telnet.pas @@ -0,0 +1,135 @@ +{$I M_OPS.PAS} + +Unit MIS_Client_Telnet; + +Interface + +Uses + {$IFDEF UNIX} + Unix, + {$ENDIF} + {$IFDEF WIN32} + Windows, + {$ENDIF} + m_Strings, + m_Socket_Class, + MIS_Common, + MIS_NodeData, + MIS_Server; + +Function CreateTelnet (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +{ must match server create or there will be access violations } + +Type + TTelnetServer = Class(TServerClient) + ND : TNodeData; + Constructor Create (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass); + Procedure Execute; Override; + Destructor Destroy; Override; + End; + +Implementation + +Function CreateTelnet (Owner: TServerManager; Config: RecConfig; ND: TNodeData; CliSock: TSocketClass) : TServerClient; +Begin + Result := TTelnetServer.Create(Owner, ND, CliSock); +End; + +Constructor TTelnetServer.Create (Owner: TServerManager; ND: TNodeData; CliSock: TSocketClass); +Begin + Inherited Create(Owner, CliSock); + + Self.ND := ND; +End; + +{$IFDEF WIN32} +Procedure TTelnetServer.Execute; +Var + Cmd : String; + SI : TStartupInfo; + PI : TProcessInformation; + Num : LongInt; + NI : TNodeInfoRec; + PassHandle : LongInt; +Begin + If Not DuplicateHandle ( + GetCurrentProcess, + Client.FSocketHandle, + GetCurrentProcess, + @PassHandle, + 0, + TRUE, + DUPLICATE_SAME_ACCESS) Then Exit; + + Num := ND.GetFreeNode; + Cmd := 'mystic.exe -n' + strI2S(Num) + ' -TID' + strI2S(PassHandle) + ' -IP' + Client.FPeerIP + ' -HOST' + Client.FPeerName + #0; + + FillChar(NI, SizeOf(NI), 0); + + NI.Num := Num; + NI.Busy := True; + NI.IP := Client.FPeerIP; + NI.User := 'Unknown'; + NI.Action := 'Logging In'; + + ND.SetNodeInfo(Num, NI); + + FillChar(SI, SizeOf(SI), 0); + FillChar(PI, SizeOf(PI), 0); + + SI.dwFlags := STARTF_USESHOWWINDOW; + SI.wShowWindow := SW_SHOWMINNOACTIVE; + + If CreateProcess(NIL, PChar(@Cmd[1]), + NIL, NIL, True, create_new_console + normal_priority_class, NIL, NIL, SI, PI) Then + WaitForSingleObject (PI.hProcess, INFINITE); + + NI.Busy := False; + NI.IP := ''; + NI.User := ''; + NI.Action := ''; + + ND.SetNodeInfo(Num, NI); +End; +{$ENDIF} + +{$IFDEF UNIX} +Procedure TTelnetServer.Execute; +Var + Cmd : String; + Num : LongInt; + NI : TNodeInfoRec; + PassHandle : LongInt; +Begin + PassHandle := Client.FSocketHandle; + + Num := ND.GetFreeNode; + Cmd := './mystic -n' + strI2S(Num) + ' -TID' + strI2S(PassHandle) + ' -UID' + Client.FPeerIP; + + FillChar(NI, SizeOf(NI), 0); + + NI.Num := Num; + NI.Busy := True; + NI.IP := Client.FPeerIP; + NI.User := 'Unknown'; + NI.Action := 'Logging In'; + + ND.SetNodeInfo(Num, NI); + + fpSystem(Cmd); + + NI.Busy := False; + NI.IP := ''; + NI.User := ''; + NI.Action := ''; + + ND.SetNodeInfo(Num, NI); +End; +{$ENDIF} + +Destructor TTelnetServer.Destroy; +Begin + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_common.pas b/mystic/mis_common.pas new file mode 100644 index 0000000..af0a8f8 --- /dev/null +++ b/mystic/mis_common.pas @@ -0,0 +1,241 @@ +Unit MIS_Common; + +{$I M_OPS.PAS} + +Interface + +{$I RECORDS.PAS} + +Var + bbsConfig : RecConfig; + +Function SearchForUser (UN: String; Var Rec: RecUser; Var RecPos: LongInt) : Boolean; +Function CheckAccess (User: RecUser; IgnoreGroup: Boolean; Str: String) : Boolean; +Function WildcardMatch (Wildcard, FName: String) : Boolean; +Function GetSecurityLevel (Level: Byte; SecLevel: RecSecurity) : Boolean; + +Implementation + +Uses + m_FileIO, + m_DateTime, + m_Strings; + +Function SearchForUser (UN: String; Var Rec: RecUser; Var RecPos: LongInt) : Boolean; +Var + UserFile : TBufFile; +Begin + Result := False; + UN := strUpper(UN); + + If UN = '' Then Exit; + + UserFile := TBufFile.Create(4096); + + If UserFile.Open(bbsConfig.DataPath + 'users.dat', fmOpen, fmRWDN, SizeOf(RecUser)) Then + While Not UserFile.EOF Do Begin + UserFile.Read(Rec); + + If Rec.Flags AND UserDeleted <> 0 Then Continue; + + If (UN = strUpper(Rec.RealName)) or (UN = strUpper(Rec.Handle)) Then Begin + RecPos := UserFile.FilePos; + Result := True; + Break; + End; + End; + + UserFile.Free; +End; + +Function CheckAccess (User: RecUser; IgnoreGroup: Boolean; Str: String) : Boolean; +Const + OpCmds = ['%', '^', '(', ')', '&', '!', '|']; + AcsCmds = ['A', 'D', 'E', 'F', 'G', 'H', 'M', 'N', 'O', 'S', 'T', 'U', 'W', 'Z']; +Var + Key : Char; + Data : String; + Check : Boolean; + Out : String; + First : Boolean; + + Procedure CheckCommand; + Var + Res : Boolean; + Temp1 : LongInt; + Temp2 : LongInt; + Begin + Res := False; + + Case Key of + 'A' : Res := True; + 'D' : Res := (Ord(Data[1]) - 64) in User.AF2; + 'E' : Case Data[1] of + '1' : Res := True; + '0' : Res := True; + End; + 'F' : Res := (Ord(Data[1]) - 64) in User.AF1; + 'G' : If IgnoreGroup Then Begin + First := True; + Check := False; + Data := ''; + Exit; + End Else + Res := User.LastMGroup = strS2I(Data); + 'H' : Res := strS2I(Data) < strS2I(Copy(TimeDos2Str(CurDateDos, False), 1, 2)); + 'M' : Res := strS2I(Data) < strS2I(Copy(TimeDos2Str(CurDateDos, False), 4, 2)); + 'N' : Res := True; + 'O' : Case Data[1] of + 'A' : Res := True; + 'I' : Res := True; + 'K' : Res := True; + 'P' : If (User.Calls > 0) And (User.Flags AND UserNoRatio = 0) Then Begin + //Temp1 := Round(Security.PCRatio / 100 * 100); + //Temp2 := Round(User.ThisUser.Posts / User.ThisUser.Calls * 100); + //Res := (Temp2 >= Temp1); + Res := True; + End Else + Res := True; + End; + 'S' : Res := User.Security >= strS2I(Data); + 'T' : Res := True; + 'U' : Res := User.PermIdx = strS2I(Data); + 'W' : Res := strS2I(Data) = m_DateTime.DayOfWeek; + 'Z' : If IgnoreGroup Then Begin + Check := False; + First := True; + Data := ''; + Exit; + End Else + Res := strS2I(Data) = User.LastFGroup; + End; + + If Res Then Out := Out + '^' Else Out := Out + '%'; + + Check := False; + First := True; + Data := ''; + End; + +Var + A : Byte; + Paran1 : Byte; + Paran2 : Byte; + Ch1 : Char; + Ch2 : Char; + S1 : String; + S2 : String; +Begin + Data := ''; + Out := ''; + Check := False; + Str := strUpper(Str); + First := True; + + For A := 1 to Length(Str) Do + If Str[A] in OpCmds Then Begin + If Check Then CheckCommand; + Out := Out + Str[A]; + End Else + If (Str[A] in AcsCmds) and (First or Check) Then Begin + If Check Then CheckCommand; + Key := Str[A]; + If First Then First := False; + End Else Begin + Data := Data + Str[A]; + Check := True; + If A = Length(Str) Then CheckCommand; + End; + + Out := '(' + Out + ')'; + + While Pos('&', Out) <> 0 Do Delete (Out, Pos('&', Out), 1); + + While Pos('(', Out) <> 0 Do Begin + Paran2 := 1; + While ((Out[Paran2] <> ')') And (Paran2 <= Length(Out))) Do Begin + If (Out[Paran2] = '(') Then Paran1 := Paran2; + Inc (Paran2); + End; + + S1 := Copy(Out, Paran1 + 1, (Paran2 - Paran1) - 1); + + While Pos('!', S1) <> 0 Do Begin + A := Pos('!', S1) + 1; + If S1[A] = '^' Then S1[A] := '%' Else + If S1[A] = '%' Then S1[A] := '^'; + Delete (S1, A - 1, 1); + End; + + While Pos('|', S1) <> 0 Do Begin + A := Pos('|', S1) - 1; + Ch1 := S1[A]; + Ch2 := S1[A + 2]; + + If (Ch1 in ['%', '^']) and (Ch2 in ['%', '^']) Then Begin + Delete (S1, A, 3); + If (Ch1 = '^') or (Ch2 = '^') Then + Insert ('^', S1, A) + Else + Insert ('%', S1, A) + End Else + Delete (S1, A + 1, 1); + End; + + While Pos('%%', S1) <> 0 Do Delete (S1, Pos('%%', S1), 1); + While Pos('^^', S1) <> 0 Do Delete (S1, Pos('^^', S1), 1); + While Pos('%^', S1) <> 0 Do Delete (S1, Pos('%^', S1) + 1, 1); + While Pos('^%', S1) <> 0 Do Delete (S1, Pos('^%', S1), 1); + + Delete (Out, Paran1, (Paran2 - Paran1) + 1); + Insert (S1, Out, Paran1); + End; + + Result := Pos('%', Out) = 0; +End; + +Function WildcardMatch (Wildcard, FName: String) : Boolean; +Begin + Result := False; + + If FName = '' Then Exit; + + Case Wildcard[1] of + '*' : Begin + If FName[1] = '.' Then Exit; + If Length(Wildcard) = 1 Then Result := True; + If (Length(Wildcard) > 1) and (Wildcard[2] = '.') and (Length(FName) > 0) Then + Result := WildCardMatch(Copy(Wildcard, 3, Length(Wildcard) - 2), Copy(FName, Pos('.', FName) + 1, Length(FName)-Pos('.', FName))); + End; + '?' : If Ord(Wildcard[0]) = 1 Then + Result := True + Else + Result := WildCardMatch(Copy(Wildcard, 2, Length(Wildcard) - 1), Copy(FName, 2, Length(FName) - 1)); + Else + If FName[1] = Wildcard[1] Then + If Length(wildcard) > 1 Then + Result := WildCardMatch(Copy(Wildcard, 2, Length(Wildcard) - 1), Copy(FName, 2, Length(FName) - 1)) + Else + Result := (Length(FName) = 1) And (Length(Wildcard) = 1); + End; +End; + +Function GetSecurityLevel (Level: Byte; SecLevel: RecSecurity) : Boolean; +Var + SecLevelFile : File of RecSecurity; +Begin + Result := False; + + Assign (SecLevelFile, bbsConfig.DataPath + 'security.dat'); + + If Not ioReset (SecLevelFile, SizeOf(SecLevel), fmRWDN) Then Exit; + + ioSeek (SecLevelFile, Level - 1); + ioRead (SecLevelFile, SecLevel); + Close (SecLevelFile); + + Result := True; +End; + + +End. diff --git a/mystic/mis_nodedata.pas b/mystic/mis_nodedata.pas new file mode 100644 index 0000000..2c5c63b --- /dev/null +++ b/mystic/mis_nodedata.pas @@ -0,0 +1,115 @@ +{$I M_OPS.PAS} + +Unit MIS_NodeData; + +// annoying node data class used until we fuse MIS and Mystic together + +Interface + +Uses + MIS_Common; + +Type + TNodeInfoRec = Record + Num : Byte; + Busy : Boolean; + User : String; + Action : String; + IP : String; + End; + + TNodeData = Class + NodeInfo : Array[1..199] of TNodeInfoRec; + NodeTotal : Byte; + Critical : TRTLCriticalSection; + + Constructor Create (Nodes: Byte); + Destructor Destroy; Override; + Function GetNodeTotal : LongInt; + Function GetNodeInfo (Num: Byte; Var NI: TNodeInfoRec): Boolean; + Procedure SetNodeInfo (Num: Byte; NI: TNodeInfoRec); + Function GetFreeNode : LongInt; + End; + +Implementation + +Uses + m_FileIO, + m_Strings; + +Function TNodeData.GetFreeNode : LongInt; +Var + Count : LongInt; +Begin + EnterCriticalSection(Critical); + + Result := -1; + + For Count := 1 to NodeTotal Do + If Not NodeInfo[Count].Busy Then Begin + NodeInfo[Count].Busy := True; + Result := NodeInfo[Count].Num; + Break; + End; + + LeaveCriticalSection(Critical); +End; + +Function TNodeData.GetNodeInfo (Num: Byte; Var NI: TNodeInfoRec) : Boolean; +Begin + EnterCriticalSection(Critical); + + Result := False; + + FillChar(NI, SizeOf(NI), 0); + + If Num <= NodeTotal Then Begin + NI := NodeInfo[Num]; + Result := True; + End; + + LeaveCriticalSection(Critical); +End; + +Procedure TNodeData.SetNodeInfo (Num: Byte; NI: TNodeInfoRec); +Var + Count : LongInt; +Begin + EnterCriticalSection(Critical); + + For Count := 1 to NodeTotal Do + If NodeInfo[Count].Num = Num Then + NodeInfo[Count] := NI; + + LeaveCriticalSection(Critical); +End; + +Function TNodeData.GetNodeTotal : LongInt; +Begin + EnterCriticalSection(Critical); + + Result := NodeTotal; + + LeaveCriticalSection(Critical); +End; + +Constructor TNodeData.Create (Nodes: Byte); +Var + Count : SmallInt; +Begin + InitCriticalSection(Critical); + + NodeTotal := Nodes; + + For Count := 1 to NodeTotal Do + NodeInfo[Count].Num := Count; +End; + +Destructor TNodeData.Destroy; +Begin + DoneCriticalSection(Critical); + + Inherited Destroy; +End; + +End. diff --git a/mystic/mis_server.pas b/mystic/mis_server.pas new file mode 100644 index 0000000..a5ac43c --- /dev/null +++ b/mystic/mis_server.pas @@ -0,0 +1,262 @@ +{$I M_OPS.PAS} + +Unit MIS_Server; + +Interface + +Uses + Classes, + m_Socket_Class, + MIS_Common, + MIS_NodeData; + +Type + TServerManager = Class; + TServerClient = Class; + TServerCreateProc = Function (Manager: TServerManager; Config: RecConfig; ND: TNodeData; Client: TSocketClass): TServerClient; + + TServerManager = Class(TThread) + NodeInfo : TNodeData; + Server : TSocketClass; + ClientList : TList; + NewClientProc : TServerCreateProc; + Config : RecConfig; + ClientMax : LongInt; + ClientMaxIPs : LongInt; + ClientRefused : LongInt; + ClientBlocked : LongInt; + ClientTotal : LongInt; + ClientActive : LongInt; + Port : LongInt; + TextPath : String[80]; + + Constructor Create (Config: RecConfig; PortNum: Word; CliMax: Word; ND: TNodeData; CreateProc: TServerCreateProc); + Destructor Destroy; Override; + Procedure Execute; Override; + Function CheckIP (IP, Mask: String) : Boolean; + Function IsBlockedIP (Var Client: TSocketClass) : Boolean; + Function DuplicateIPs (Var Client: TSocketClass) : Byte; + End; + + TServerClient = Class(TThread) + Client : TSocketClass; + Manager : TServerManager; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Destructor Destroy; Override; + End; + +Implementation + +Uses + m_Strings, + m_DateTime; + +Constructor TServerManager.Create (Config: RecConfig; PortNum: Word; CliMax: Word; ND: TNodeData; CreateProc: TServerCreateProc); +Var + Count : Byte; +Begin + Inherited Create(False); + + Port := PortNum; + ClientMax := CliMax; + ClientRefused := 0; + ClientBlocked := 0; + ClientTotal := 0; + ClientActive := 0; + ClientMaxIPs := 1; + NewClientProc := CreateProc; + Server := TSocketClass.Create; + ClientList := TList.Create; + TextPath := Config.DataPath; + NodeInfo := ND; + Config := Config; + + For Count := 1 to ClientMax Do + ClientList.Add(NIL); + + FreeOnTerminate := False; +End; + +Function TServerManager.CheckIP (IP, Mask: String) : Boolean; +Var + A : Byte; + Count : Byte; + Str : String; + Str2 : String; + EndIt : Byte; +Begin + Result := True; + + For Count := 1 to 4 Do Begin + If Count < 4 Then Begin + Str := Copy(IP, 1, Pos('.', IP) - 1); + Str2 := Copy(Mask, 1, Pos('.', Mask) - 1); + Delete (IP, 1, Pos('.', IP)); + Delete (Mask, 1, Pos('.', Mask)); + End Else Begin + Str := Copy(IP, 1, Length(IP)); + Str2 := Copy(Mask, 1, Length(Mask)); + End; + + For A := 1 to Length(Str) Do + If Str2[A] = '*' Then + Break + Else + If Str[A] <> Str2[A] Then Begin + Result := False; + Break; + End; + + If Not Result Then Break; + End; +End; + +Function TServerManager.IsBlockedIP (Var Client: TSocketClass) : Boolean; +Var + TF : Text; + Str : String; +Begin + Result := False; + FileMode := 66; + + Assign (TF, TextPath + 'badip.txt'); + Reset (TF); + + If IoResult = 0 Then Begin + While Not Eof(TF) Do Begin + ReadLn (TF, Str); + If CheckIP (Client.PeerIP, Str) Then Begin + Result := True; + Break; + End; + End; + + Close (TF); + End; +End; + +Function TServerManager.DuplicateIPs (Var Client: TSocketClass) : Byte; +Var + Count : Byte; +Begin + Result := 0; + + For Count := 0 to ClientMax - 1 Do + If ClientList[Count] <> NIL Then // use Assigned? + If Client.PeerIP = TSocketClass(ClientList[Count]).PeerIP Then + Inc(Result); +End; + +Procedure TServerManager.Execute; +Var + NewClient : TSocketClass; +Begin + Repeat Until Server <> NIL; // Synchronize with server class + Repeat Until Server.SocketStatus <> NIL; // Syncronize with status class + + Server.WaitInit(Port); + + If Terminated Then Exit; + + If ClientMax = 0 Then + Server.Status('WARNING: At least one server is configured with 0 max clients.'); + + Server.Status('Opening server socket on port ' + strI2S(Port)); + + Repeat + NewClient := Server.WaitConnection; + + If NewClient = NIL Then Break; // time to shutdown the server... + + If (ClientMax > 0) And (ClientActive >= ClientMax) Then Begin + Inc (ClientRefused); + Server.Status ('BUSY: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'busy.txt') Then NewClient.WriteLine('BUSY'); + NewClient.Free; + End Else + If IsBlockedIP(NewClient) Then Begin + Inc (ClientBlocked); + Server.Status('BLOCK: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'blocked.txt') Then NewClient.WriteLine('BLOCKED'); + NewClient.Free; + End Else + If (ClientMaxIPs > 0) and (DuplicateIPs(NewClient) > ClientMaxIPs) Then Begin + Inc (ClientRefused); + Server.Status('MULTI: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'dupeip.txt') Then NewClient.WriteLine('Only ' + strI2S(ClientMaxIPs) + ' connection(s) per user'); + NewClient.Free; + End Else Begin + Inc (ClientTotal); + Inc (ClientActive); + Server.Status ('Connect: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + + NewClientProc(Self, Config, NodeInfo, NewClient); + End; + Until Terminated; + + Server.Status ('Shutting down server...'); +End; + +Destructor TServerManager.Destroy; +Var + Count : LongInt; + Angry : Byte; +Begin + Angry := 20; // about 5 seconds before we get mad at thread... + + ClientList.Pack; + + While (ClientList.Count > 0) and (Angry > 0) Do Begin + For Count := 0 To ClientList.Count - 1 Do + If ClientList[Count] <> NIL Then Begin + TServerClient(ClientList[Count]).Client.Disconnect; + TServerClient(ClientList[Count]).Terminate; + End; + + WaitMS(250); + + Dec (Angry); + + ClientList.Pack; + End; + + ClientList.Free; + Server.Free; + + Inherited Destroy; +End; + +Constructor TServerClient.Create (Owner: TServerManager; CliSock: TSocketClass); +Var + Count : Byte; +Begin + Manager := Owner; + Client := CliSock; + + For Count := 0 to Manager.ClientMax - 1 Do + If Manager.ClientList[Count] = NIL Then Begin + Manager.ClientList[Count] := Self; + Break; + End; + + Inherited Create(False); + + FreeOnTerminate := True; +End; + +Destructor TServerClient.Destroy; +Begin + Client.Free; + + Manager.ClientList[Manager.ClientList.IndexOf(Self)] := NIL; + + If Manager.Server <> NIL Then + Manager.Server.StatusUpdated := True; + + Dec (Manager.ClientActive); + + Inherited Destroy; +End; + +End. diff --git a/mystic/mkcrap.pas b/mystic/mkcrap.pas new file mode 100644 index 0000000..61128eb --- /dev/null +++ b/mystic/mkcrap.pas @@ -0,0 +1,305 @@ +{$I M_OPS.PAS} + +Unit mkcrap; + +// this is various functions and procedures used by JAM/Squish... +// these should be removed and/or incorporated into mystic's code base as +// soon as possible. + +// CHANGE JAM TEMP BUFFER.. ADD SETBUFFERFILE METHOD TO MSGBASE OBJECTS!!!! + +interface + +uses + dos; + +Function ToUnixDate(FDate: LongInt): LongInt; +Function DTToUnixDate(DT: DateTime): LongInt; +Procedure UnixToDT(SecsPast: LongInt; Var Dt: DateTime); +Function SaveFile(FN: String; Var Rec; FS: Word): Word; +Procedure Str2Az(Str: String; MaxLen: Byte; Var AZStr); {Convert string to asciiz} +Function FormattedDate(DT: DateTime; Mask: String): String; +Function LoadFile(FN: String; Var Rec; FS: Word): Word; +Function LoadFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word; +Function GetFileSize (FN : String) : LongInt; +Function ExtendFile(FN: String; ToSize: LongInt): Word; +Function SaveFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word; + +implementation + +Uses + m_FileIO, + m_DateTime, + m_Strings; + +Const + DATEC1970 = 2440588; +// DATED0 = 1461; +// DATED1 = 146097; +// DATED2 = 1721119; + +Function DTToUnixDate(DT: DateTime): LongInt; +Var + SecsPast, DaysPast: LongInt; +Begin + DateG2J (DT.Year, DT.Month, DT.Day, DaysPast); + DaysPast := DaysPast - DATEc1970; + SecsPast := DaysPast * 86400; + SecsPast := SecsPast + (LongInt(DT.Hour) * 3600) + (DT.Min * 60) + (DT.Sec); + DTToUnixDate := SecsPast; +End; + +Function ToUnixDate(FDate: LongInt): LongInt; +Var + DT: DateTime; +Begin + UnpackTime(Fdate, DT); + ToUnixDate := DTToUnixDate(Dt); +End; + +Procedure UnixToDT(SecsPast: LongInt; Var Dt: DateTime); +Var + DateNum : LongInt; //might be able to remove this +Begin + Datenum := (SecsPast Div 86400) + DATEc1970; + + FillChar(DT, SizeOf(DT), 0); + + DateJ2G(DateNum, SmallInt(DT.Year), SmallInt(DT.Month), SmallInt(DT.Day)); + + SecsPast := SecsPast Mod 86400; + DT.Hour := SecsPast Div 3600; + SecsPast := SecsPast Mod 3600; + DT.Min := SecsPast Div 60; + DT.Sec := SecsPast Mod 60; +End; + +Function SaveFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word; +Var + F: File; + Error: Word; + temp:longint; +Begin + Error := 0; + assign (f, fn); + + FileMode := fmReadWrite + fmDenyNone; + If FileExist(FN) Then Begin + reset(f,1); + if ioresult <> 0 then error := ioresult; + End Else Begin + ReWrite(F,1); + Error := IoResult; + End; + If Error = 0 Then Begin + Seek(F, FPos); + Error := IoResult; + End; + If Error = 0 Then + If FS > 0 Then Begin + If Not ioBlockWrite(F, Rec, FS, Temp) Then Error := ioCode; + End; + If Error = 0 Then Begin + Close(F); + Error := IoResult; + End; + SaveFilePos := Error; +End; + +Function SaveFile(FN: String; Var Rec; FS: Word): Word; + Begin + SaveFile := SaveFilePos(FN, Rec, FS, 0); + End; + + + +Procedure Str2Az(Str: String; MaxLen: Byte; Var AZStr); {Convert string to asciiz} + Begin + If Length(Str) >= MaxLen Then + Begin + Str[MaxLen] := #0; + Move(Str[1], AZStr, MaxLen); + End + Else + Begin + Str[Length(Str) + 1] := #0; + Move(Str[1], AZStr, Length(Str) + 1); + End; + End; + +Function MonthStr(MonthNo: Word): String; +Begin + Case MonthNo of + 01: MonthStr := 'Jan'; + 02: MonthStr := 'Feb'; + 03: MonthStr := 'Mar'; + 04: MonthStr := 'Apr'; + 05: MonthStr := 'May'; + 06: MonthStr := 'Jun'; + 07: MonthStr := 'Jul'; + 08: MonthStr := 'Aug'; + 09: MonthStr := 'Sep'; + 10: MonthStr := 'Oct'; + 11: MonthStr := 'Nov'; + 12: MonthStr := 'Dec'; + Else + MonthStr := '???'; + End; +End; + + +Function FormattedDate(DT: DateTime; Mask: String): String; +Var + DStr : String[2]; + MStr : String[2]; + MNStr : String[3]; + YStr : String[4]; + HourStr : String[2]; + MinStr : String[2]; + SecStr : String[2]; + TmpStr : String; + CurrPos : Word; + i : Word; +Begin + TmpStr := Mask; + Mask := strUpper(Mask); + DStr := Copy(strPadL(strI2S(Dt.Day), 2, '0'), 1, 2); + MStr := Copy(strPadL(strI2S(Dt.Month), 2, '0'), 1, 2); + YStr := Copy(strPadL(strI2S(Dt.Year), 4, '0'), 1, 4); + HourStr := Copy(strPadL(strI2S(Dt.Hour), 2, ' '), 1, 2); + MinStr := Copy(strPadL(strI2S(Dt.Min), 2, '0'), 1, 2); + SecStr := Copy(strPadL(strI2S(Dt.Sec), 2, '0'), 1, 2); + MNStr := MonthStr(Dt.Month); + If (Pos('YYYY', Mask) = 0) Then YStr := Copy(YStr,3,2); + CurrPos := Pos('DD', Mask); + If CurrPos > 0 Then + For i := 1 to Length(DStr) Do + TmpStr[CurrPos + i - 1] := DStr[i]; + CurrPos := Pos('YY', Mask); + If CurrPos > 0 Then + For i := 1 to Length(YStr) Do + TmpStr[CurrPos + i - 1] := YStr[i]; + CurrPos := Pos('MM', Mask); + If CurrPos > 0 Then + For i := 1 to Length(MStr) Do + TmpStr[CurrPos + i - 1] := MStr[i]; + CurrPos := Pos('HH', Mask); + If CurrPos > 0 Then + For i := 1 to Length(HourStr) Do + TmpStr[CurrPos + i - 1] := HourStr[i]; + CurrPos := Pos('SS', Mask); + If CurrPos > 0 Then + For i := 1 to Length(SecStr) Do + TmpStr[CurrPos + i - 1] := SecStr[i]; + CurrPos := Pos('II', Mask); + If CurrPos > 0 Then + For i := 1 to Length(MinStr) Do + TmpStr[CurrPos + i - 1] := MinStr[i]; + CurrPos := Pos('NNN', Mask); + If CurrPos > 0 Then + For i := 1 to Length(MNStr) Do + TmpStr[CurrPos + i - 1] := MNStr[i]; + FormattedDate := TmpStr; + End; + + +Function LoadFilePos(FN: String; Var Rec; FS: Word; FPos: LongInt): Word; +Var + F: File; + Error: Word; + NumRead: LongInt; + Begin + Error := 0; + If Not FileExist(FN) Then Error := 8888; + If Error = 0 Then assign (f, fn); + FileMode := fmReadWrite + fmDenyNone; + reset (f, 1); + error := ioresult; + If Error = 0 Then Begin + Seek(F, FPos); + Error := IoResult; + End; + If Error = 0 Then + If Not ioBlockRead(F, Rec, FS, NumRead) Then + Error := ioCode; + If Error = 0 Then + Begin + Close(F); + Error := IoResult; + End; + LoadFilePos := Error; + End; + +Function LoadFile(FN: String; Var Rec; FS: Word): Word; + Begin + LoadFile := LoadFilePos(FN, Rec, FS, 0); + End; + +Function GetFileSize (FN : String) : LongInt; +Var + SR : SearchRec; +Begin + FindFirst (FN, AnyFile, SR); + If DosError = 0 Then + GetFileSize := SR.Size + Else + GetFileSize := -1; +End; + +Function ExtendFile(FN: String; ToSize: LongInt): Word; +{Pads file with nulls to specified size} + Type + FillType = Array[1..8000] of Byte; + + Var + F: File; + Error: Word; + FillRec: ^FillType; + temp:longint; + + Begin + Error := 0; + New(FillRec); + If FillRec = Nil Then + Error := 10; + If Error = 0 Then + Begin + FillChar(FillRec^, SizeOf(FillRec^), 0); + Assign(F, FN); + FileMode := fmReadWrite + fmDenyNone; + If FileExist(FN) Then Begin + reset(f,1); + if ioresult <> 0 then error := ioresult; + End + Else + Begin + ReWrite(F,1); + Error := IoResult; + End; + End; + If Error = 0 Then + Begin + Seek(F, FileSize(F)); + Error := IoResult; + End; + If Error = 0 Then + Begin + While ((FileSize(F) < (ToSize - SizeOf(FillRec^))) and (Error = 0)) Do + Begin + If Not ioBlockWrite(F, FillRec^, SizeOf(FillRec^), Temp) Then + Error := ioCode; + End; + End; + If ((Error = 0) and (FileSize(F) < ToSize)) Then Begin + If Not ioBlockWrite(F, FillRec^, ToSize - FileSize(F), temp) Then + Error := ioCode; + End; + If Error = 0 Then Begin + Close(F); + Error := IoResult; + End; + Dispose(FillRec); + ExtendFile := Error; + End; + +End. diff --git a/mystic/mpl_common.pas b/mystic/mpl_common.pas new file mode 100644 index 0000000..bdb523a --- /dev/null +++ b/mystic/mpl_common.pas @@ -0,0 +1,365 @@ + +Function cGetVarChar (T: TIdentTypes) : Char; +Begin + Case T of + iString : Result := 's'; + iChar : Result := 'c'; + iByte : Result := 'b'; + iShort : Result := 'h'; + iWord : Result := 'w'; + iInteger : Result := 'i'; + iLongInt : Result := 'l'; + iReal : Result := 'r'; + iBool : Result := 'o'; + iFile : Result := 'f'; + iRecord : Result := 'x'; + Else + Result := ' '; + End; +End; + +Function cVarType (C: Char) : TIdentTypes; +begin + case UpCase(c) of + 'S' : cVarType := iString; + 'C' : cVarType := iChar; + 'B' : cVarType := iByte; + 'H' : cVarType := iShort; + 'W' : cVarType := iWord; + 'I' : cVarType := iInteger; + 'L' : cVarType := iLongInt; + 'R' : cVarType := iReal; + 'O' : cVarType := iBool; + 'F' : cVarType := iFile; + 'X' : cVarType := iRecord; + else + cVarType := iNone; + end; +end; + +Function xVarSize (T: TIdentTypes) : Word; +Begin + Case T of + iRecord, + iNone : xVarSize := 0; + iString : xVarSize := 256; + iChar : xVarSize := 1; + iByte : xVarSize := 1; + iShort : xVarSize := 1; + iWord : xVarSize := 2; + iInteger : xVarSize := 2; + iLongInt : xVarSize := 4; + iReal : xVarSize := SizeOf(Real); // {$IFDEF FPC}8{$ELSE}6{$ENDIF}; + iBool : xVarSize := 1; + iFile : xVarSize := SizeOf(File); // was 128; + End; +End; + +Procedure InitProcedures (O: Pointer; S: Pointer; Var CV: VarDataRec; Var X: Word; Var IW: Word; Mode: Byte); + + Procedure AddProc ({$IFDEF MPLPARSER} I: String; {$ENDIF} P: String; T: TIdentTypes); + Begin + Inc(X); + New(CV[X]); + + With CV[X]^ Do Begin + VarID := IW; + Inc(IW); + vType := T; + Move(P[1], Params, Ord(P[0])); + NumParams := Ord(p[0]); + {$IFNDEF MPLPARSER} + VarSize := 0; + DataSize := 0; + Data := NIL; + ProcPos := 0; + Kill := True; + FillChar (pID, SizeOf(pID), 0); + {$ELSE} + Ident := I; + InProc := False; + Proc := True; + {$ENDIF} + ArrPos := 0; + End; + End; + + Procedure AddStr ({$IFDEF MPLPARSER} I: String; {$ENDIF} T: TIdentTypes; SI: Word); + Begin + Inc(X); + New(CV[X]); + + With cV[x]^ Do Begin + VarID := IW; + Inc(IW); + vType := T; + NumParams := 0; + {$IFNDEF MPLPARSER} + VarSize := SI + 1; + DataSize := VarSize; + GetMem (Data, DataSize); + FillChar (Data^, DataSize, 0); + FillChar (pID, SizeOf(pID), 0); //cant we just assign it to 0 here? + ProcPos := 0; + Kill := True; + {$ELSE} + Ident := I; + InProc := False; + Proc := False; + {$ENDIF} + ArrPos := 0; + End; + End; + + Procedure AddVar ({$IFDEF MPLPARSER} I: String; {$ENDIF} T: TIdentTypes); + Begin + AddStr ({$IFDEF MPLPARSER} I, {$ENDIF} T, xVarSize(T) - 1); + End; + + Procedure AddPointer ({$IFDEF MPLPARSER} I: String; {$ENDIF} T: TIdentTypes; SI: Word; PD: Pointer); + Begin + Inc(x); + New(cV[x]); + + With cV[x]^ Do Begin + VarID := IW; + Inc(IW); + vType := t; + NumParams := 0; + {$IFNDEF MPLPARSER} + If T = iString Then VarSize := SI + 1 Else VarSize := SI; + DataSize := VarSize; + Data := PD; + FillChar (pID, SizeOf(pID), 0); + ProcPos := 0; + Kill := False; + {$ELSE} + Ident := I; + InProc := False; + Proc := False; + {$ENDIF} + ArrPos := 0; + End; + End; + +Begin + Case Mode of + 0 : Begin + IW := 0; + + AddProc ({$IFDEF MPLPARSER} 'write', {$ENDIF} 's', iNone); // 0 + AddProc ({$IFDEF MPLPARSER} 'writeln', {$ENDIF} 's', iNone); // 1 + AddProc ({$IFDEF MPLPARSER} 'clrscr', {$ENDIF} '', iNone); // 2 + AddProc ({$IFDEF MPLPARSER} 'clreol', {$ENDIF} '', iNone); // 3 + AddProc ({$IFDEF MPLPARSER} 'gotoxy', {$ENDIF} 'bb', iNone); // 4 + AddProc ({$IFDEF MPLPARSER} 'wherex', {$ENDIF} '', iByte); // 5 + AddProc ({$IFDEF MPLPARSER} 'wherey', {$ENDIF} '', iByte); // 6 + AddProc ({$IFDEF MPLPARSER} 'readkey', {$ENDIF} '', iString); // 7 + AddProc ({$IFDEF MPLPARSER} 'delay', {$ENDIF} 'l', iNone); // 8 + AddProc ({$IFDEF MPLPARSER} 'random', {$ENDIF} 'l', iLongInt); // 9 + AddProc ({$IFDEF MPLPARSER} 'chr', {$ENDIF} 'b', iChar); // 10 + AddProc ({$IFDEF MPLPARSER} 'ord', {$ENDIF} 's', iByte); // 11 + AddProc ({$IFDEF MPLPARSER} 'copy', {$ENDIF} 'sll', iString); // 12 + AddProc ({$IFDEF MPLPARSER} 'delete', {$ENDIF} 'Sll', iNone); // 13 + AddProc ({$IFDEF MPLPARSER} 'insert', {$ENDIF} 'sSl', iNone); // 14 + AddProc ({$IFDEF MPLPARSER} 'length', {$ENDIF} 's', iLongInt); // 15 + AddProc ({$IFDEF MPLPARSER} 'odd', {$ENDIF} 'l', iBool); // 16 + AddProc ({$IFDEF MPLPARSER} 'pos', {$ENDIF} 'ss', iLongInt); // 17 + AddProc ({$IFDEF MPLPARSER} 'keypressed', {$ENDIF} '', iBool); // 18 + AddProc ({$IFDEF MPLPARSER} 'padrt', {$ENDIF} 'sbs', iString); // 19 + AddProc ({$IFDEF MPLPARSER} 'padlt', {$ENDIF} 'sbs', iString); // 20 + AddProc ({$IFDEF MPLPARSER} 'padct', {$ENDIF} 'sbs', iString); // 21 + AddProc ({$IFDEF MPLPARSER} 'upper', {$ENDIF} 's', iString); // 22 + AddProc ({$IFDEF MPLPARSER} 'lower', {$ENDIF} 's', iString); // 23 + AddProc ({$IFDEF MPLPARSER} 'strrep', {$ENDIF} 'sb', iString); // 24 + AddProc ({$IFDEF MPLPARSER} 'strcomma', {$ENDIF} 'l', iString); // 25 + AddProc ({$IFDEF MPLPARSER} 'int2str', {$ENDIF} 'l', iString); // 26 + AddProc ({$IFDEF MPLPARSER} 'str2int', {$ENDIF} 's', iLongInt); // 27 + AddProc ({$IFDEF MPLPARSER} 'int2hex', {$ENDIF} 'l', iString); // 28 + AddProc ({$IFDEF MPLPARSER} 'wordget', {$ENDIF} 'bss', iString); // 29 + AddProc ({$IFDEF MPLPARSER} 'wordpos', {$ENDIF} 'bss', iByte); // 30 + AddProc ({$IFDEF MPLPARSER} 'wordcount', {$ENDIF} 'ss', iByte); // 31 + AddProc ({$IFDEF MPLPARSER} 'stripl', {$ENDIF} 'ss', iString); // 32 + AddProc ({$IFDEF MPLPARSER} 'stripr', {$ENDIF} 'ss', iString); // 33 + AddProc ({$IFDEF MPLPARSER} 'stripb', {$ENDIF} 'ss', iString); // 34 + AddProc ({$IFDEF MPLPARSER} 'striplow', {$ENDIF} 's', iString); // 35 + AddProc ({$IFDEF MPLPARSER} 'stripmci', {$ENDIF} 's', iString); // 36 + AddProc ({$IFDEF MPLPARSER} 'mcilength', {$ENDIF} 's', iByte); // 37 + AddProc ({$IFDEF MPLPARSER} 'initials', {$ENDIF} 's', iString); // 38 + AddProc ({$IFDEF MPLPARSER} 'strwrap', {$ENDIF} 'SSb', iByte); // 39 + AddProc ({$IFDEF MPLPARSER} 'replace', {$ENDIF} 'sss', iString); // 40 + AddProc ({$IFDEF MPLPARSER} 'readenv', {$ENDIF} 's', iString); // 41 + AddProc ({$IFDEF MPLPARSER} 'fileexist', {$ENDIF} 's', iBool); // 42 + AddProc ({$IFDEF MPLPARSER} 'fileerase', {$ENDIF} 's', iNone); // 43 + AddProc ({$IFDEF MPLPARSER} 'direxist', {$ENDIF} 's', iBool); // 44 + AddProc ({$IFDEF MPLPARSER} 'timermin', {$ENDIF} '', iLongInt); // 45 + AddProc ({$IFDEF MPLPARSER} 'timer', {$ENDIF} '', iLongInt); // 46 + AddProc ({$IFDEF MPLPARSER} 'datetime', {$ENDIF} '', iLongInt); // 47 + AddProc ({$IFDEF MPLPARSER} 'datejulian', {$ENDIF} '', iLongInt); // 48 + AddProc ({$IFDEF MPLPARSER} 'datestr', {$ENDIF} 'lb', iString); // 49 + AddProc ({$IFDEF MPLPARSER} 'datestrjulian', {$ENDIF} 'lb', iString); // 50 + AddProc ({$IFDEF MPLPARSER} 'date2dos', {$ENDIF} 's', iLongInt); // 51 + AddProc ({$IFDEF MPLPARSER} 'date2julian', {$ENDIF} 's', iLongInt); // 52 + AddProc ({$IFDEF MPLPARSER} 'dateg2j', {$ENDIF} 'lllL', iNone); // 53 + AddProc ({$IFDEF MPLPARSER} 'datej2g', {$ENDIF} 'liii', iNone); // 54 + AddProc ({$IFDEF MPLPARSER} 'datevalid', {$ENDIF} 's', iString); // 55 + AddProc ({$IFDEF MPLPARSER} 'timestr', {$ENDIF} 'lo', iString); // 56 + AddProc ({$IFDEF MPLPARSER} 'dayofweek', {$ENDIF} '', iByte); // 57 + AddProc ({$IFDEF MPLPARSER} 'daysago', {$ENDIF} 'l', iLongInt); // 58 + AddProc ({$IFDEF MPLPARSER} 'justfile', {$ENDIF} 's', iString); // 59 + AddProc ({$IFDEF MPLPARSER} 'justfilename', {$ENDIF} 's', iString); // 60 + AddProc ({$IFDEF MPLPARSER} 'justfileext', {$ENDIF} 's', iString); // 61 + AddProc ({$IFDEF MPLPARSER} 'fassign', {$ENDIF} 'Fsl', iNone); // 62 + AddProc ({$IFDEF MPLPARSER} 'freset', {$ENDIF} 'F', iNone); // 63 + AddProc ({$IFDEF MPLPARSER} 'frewrite', {$ENDIF} 'F', iNone); // 64 + AddProc ({$IFDEF MPLPARSER} 'fclose', {$ENDIF} 'F', iNone); // 65 + AddProc ({$IFDEF MPLPARSER} 'fseek', {$ENDIF} 'Fl', iNone); // 66 + AddProc ({$IFDEF MPLPARSER} 'feof', {$ENDIF} 'F', iBool); // 67 + AddProc ({$IFDEF MPLPARSER} 'fsize', {$ENDIF} 'F', iLongInt); // 68 + AddProc ({$IFDEF MPLPARSER} 'fpos', {$ENDIF} 'F', iLongInt); // 69 + AddProc ({$IFDEF MPLPARSER} 'fread', {$ENDIF} 'F*w', iNone); // 70 + AddProc ({$IFDEF MPLPARSER} 'fwrite', {$ENDIF} 'F*w', iNone); // 71 + AddProc ({$IFDEF MPLPARSER} 'freadln', {$ENDIF} 'FS', iNone); // 72 + AddProc ({$IFDEF MPLPARSER} 'fwriteln', {$ENDIF} 'Fs', iNone); // 73 + AddProc ({$IFDEF MPLPARSER} 'pathchar', {$ENDIF} '', iChar); // 74 + AddProc ({$IFDEF MPLPARSER} 'bitcheck', {$ENDIF} 'b*', iBool); // 75 + AddProc ({$IFDEF MPLPARSER} 'bittoggle', {$ENDIF} 'b*', iNone); // 76 + AddProc ({$IFDEF MPLPARSER} 'bitset', {$ENDIF} 'b*o', iNone); // 77 + AddProc ({$IFDEF MPLPARSER} 'findfirst', {$ENDIF} 'sw', iNone); // 78 + AddProc ({$IFDEF MPLPARSER} 'findnext', {$ENDIF} '', iNone); // 79 + AddProc ({$IFDEF MPLPARSER} 'findclose', {$ENDIF} '', iNone); // 80 + AddProc ({$IFDEF MPLPARSER} 'justpath', {$ENDIF} 's', iString); // 81 + AddProc ({$IFDEF MPLPARSER} 'randomize', {$ENDIF} '', iNone); // 82 + AddProc ({$IFDEF MPLPARSER} 'paramcount', {$ENDIF} '', iByte); // 83 + AddProc ({$IFDEF MPLPARSER} 'paramstr', {$ENDIF} 'b', iString); // 84 + AddProc ({$IFDEF MPLPARSER} 'textattr', {$ENDIF} '', iByte); // 85 + AddProc ({$IFDEF MPLPARSER} 'textcolor', {$ENDIF} 'b', iNone); // 86 + AddProc ({$IFDEF MPLPARSER} 'addslash', {$ENDIF} 's', iString); // 87 + AddProc ({$IFDEF MPLPARSER} 'strippipe', {$ENDIF} 's', iString); // 88 + + IW := 500; // BEGIN BBS-SPECIFIC STUFF + + AddProc ({$IFDEF MPLPARSER} 'input', {$ENDIF} 'bbbs', iString); // 500 + AddProc ({$IFDEF MPLPARSER} 'getuser', {$ENDIF} 'l', iBool); // 501 + AddProc ({$IFDEF MPLPARSER} 'onekey', {$ENDIF} 'so', iChar); // 502 + AddProc ({$IFDEF MPLPARSER} 'getthisuser', {$ENDIF} '', iNone); // 503 + AddProc ({$IFDEF MPLPARSER} 'inputyn', {$ENDIF} 's', iBool); // 504 + AddProc ({$IFDEF MPLPARSER} 'inputny', {$ENDIF} 's', iBool); // 505 + AddProc ({$IFDEF MPLPARSER} 'dispfile', {$ENDIF} 's', iBool); // 506 + AddProc ({$IFDEF MPLPARSER} 'filecopy', {$ENDIF} 'ss', iBool); // 507 + AddProc ({$IFDEF MPLPARSER} 'menucmd', {$ENDIF} 'ss', iNone); // 508 + AddProc ({$IFDEF MPLPARSER} 'stuffkey', {$ENDIF} 's', iNone); // 509 + AddProc ({$IFDEF MPLPARSER} 'acs', {$ENDIF} 's', iBool); // 510 + AddProc ({$IFDEF MPLPARSER} 'upuser', {$ENDIF} 'i', iNone); // 511 + AddProc ({$IFDEF MPLPARSER} 'setusertime', {$ENDIF} 'i', iNone); // 512 + AddProc ({$IFDEF MPLPARSER} 'hangup', {$ENDIF} '', iNone); // 513 + AddProc ({$IFDEF MPLPARSER} 'getmbase', {$ENDIF} 'l', iBool); // 514 + AddProc ({$IFDEF MPLPARSER} 'getprompt', {$ENDIF} 'l', iString); // 515 + AddProc ({$IFDEF MPLPARSER} 'getmgroup', {$ENDIF} 'l', iBool); // 516 + AddProc ({$IFDEF MPLPARSER} 'purgeinput', {$ENDIF} '', iNone); // 517 + AddProc ({$IFDEF MPLPARSER} 'getfbase', {$ENDIF} 'l', iBool); // 518 + AddProc ({$IFDEF MPLPARSER} 'getfgroup', {$ENDIF} 'l', iBool); // 519 + AddProc ({$IFDEF MPLPARSER} 'sysoplog', {$ENDIF} 's', iNone); // 520 + AddProc ({$IFDEF MPLPARSER} 'movex', {$ENDIF} 'b', iNone); // 521 + AddProc ({$IFDEF MPLPARSER} 'movey', {$ENDIF} 'b', iNone); // 522 + AddProc ({$IFDEF MPLPARSER} 'writepipe', {$ENDIF} 's', iNone); // 523 + AddProc ({$IFDEF MPLPARSER} 'writepipeln', {$ENDIF} 's', iNone); // 524 + AddProc ({$IFDEF MPLPARSER} 'writeraw', {$ENDIF} 's', iNone); // 525 + AddProc ({$IFDEF MPLPARSER} 'writerawln', {$ENDIF} 's', iNone); // 526 + AddProc ({$IFDEF MPLPARSER} 'mci2str', {$ENDIF} 's', iString); // 527 + AddProc ({$IFDEF MPLPARSER} 'getusertime', {$ENDIF} '', iInteger); // 528 + AddProc ({$IFDEF MPLPARSER} 'getscreeninfo', {$ENDIF} 'bBBB', iNone); // 529 + AddProc ({$IFDEF MPLPARSER} 'setprompt', {$ENDIF} 'bs', iNone); // 530 + AddProc ({$IFDEF MPLPARSER} 'moreprompt', {$ENDIF} '', iChar); // 531 + AddProc ({$IFDEF MPLPARSER} 'pause', {$ENDIF} '', iNone); // 532 + AddProc ({$IFDEF MPLPARSER} 'setpromptinfo', {$ENDIF} 'bs', iNone); // 533 + AddProc ({$IFDEF MPLPARSER} 'bufflush', {$ENDIF} '', iNone); // 534 + AddProc ({$IFDEF MPLPARSER} 'strmci', {$ENDIF} 's', iString); // 535 + AddProc ({$IFDEF MPLPARSER} 'getcharxy', {$ENDIF} 'bb', iChar); // 536 + AddProc ({$IFDEF MPLPARSER} 'getattrxy', {$ENDIF} 'bb', iByte); // 537 + +{ END OF PROCEDURE DEFINITIONS } + + AddPointer ({$IFDEF MPLPARSER} 'ioresult', {$ENDIF} iLongInt, 4, {$IFNDEF MPLPARSER} @TInterpEngine(S).IoError {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'doserror', {$ENDIF} iInteger, 2, {$IFNDEF MPLPARSER} @DosError {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'progparams', {$ENDIF} iString, 256, {$IFNDEF MPLPARSER} @TInterpEngine(S).ParamsStr {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'progname', {$ENDIF} iString, 256, {$IFNDEF MPLPARSER} @TInterpEngine(S).MPEName {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'graphics', {$ENDIF} iByte, 1, {$IFNDEF MPLPARSER} @Session.io.Graphics {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'isarrow', {$ENDIF} iBool, 1, {$IFNDEF MPLPARSER} @Session.io.IsArrow {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'nodenum', {$ENDIF} iByte, 1, {$IFNDEF MPLPARSER} @Session.NodeNum {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'local', {$ENDIF} iBool, 1, {$IFNDEF MPLPARSER} @Session.LocalMode {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'allowarrow', {$ENDIF} iBool, 1, {$IFNDEF MPLPARSER} @Session.io.AllowArrow {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'ignoregroups', {$ENDIF} iBool, 1, {$IFNDEF MPLPARSER} @Session.User.IgnoreGroup {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'pausepos', {$ENDIF} iByte, 1, {$IFNDEF MPLPARSER} @Session.io.PausePtr {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'allowmci', {$ENDIF} iBool, 1, {$IFNDEF MPLPARSER} @Session.io.PausePtr {$ELSE} NIL {$ENDIF}); + + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarDir := X + 1; {$ENDIF} + + AddPointer ({$IFDEF MPLPARSER} 'dirname', {$ENDIF} iString, 256, {$IFNDEF MPLPARSER} @TInterpEngine(S).DirInfo.Name {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'dirsize', {$ENDIF} iLongInt, 4, {$IFNDEF MPLPARSER} @TInterpEngine(S).DirInfo.Size {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'dirtime', {$ENDIF} iLongInt, 4, {$IFNDEF MPLPARSER} @TInterpEngine(S).DirInfo.Time {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'dirattr', {$ENDIF} iByte, 1, {$IFNDEF MPLPARSER} @TInterpEngine(S).DirInfo.Attr {$ELSE} NIL {$ENDIF}); + End; + 1 : Begin + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarUser := X + 1; {$ENDIF} + + AddVar ({$IFDEF MPLPARSER} 'userpermidx', {$ENDIF} iLongInt); + AddStr ({$IFDEF MPLPARSER} 'username', {$ENDIF} iString, 30); + AddStr ({$IFDEF MPLPARSER} 'useralias', {$ENDIF} iString, 30); + AddStr ({$IFDEF MPLPARSER} 'useraddress', {$ENDIF} iString, 30); + AddVar ({$IFDEF MPLPARSER} 'usersec', {$ENDIF} iInteger); + AddVar ({$IFDEF MPLPARSER} 'usersex', {$ENDIF} iChar); + AddVar ({$IFDEF MPLPARSER} 'userfirston', {$ENDIF} iLongInt); + AddVar ({$IFDEF MPLPARSER} 'userlaston', {$ENDIF} iLongInt); + AddVar ({$IFDEF MPLPARSER} 'userdatetype', {$ENDIF} iByte); + AddVar ({$IFDEF MPLPARSER} 'usercalls', {$ENDIF} iLongInt); + AddVar ({$IFDEF MPLPARSER} 'userpassword', {$ENDIF} iString); + AddVar ({$IFDEF MPLPARSER} 'userflags', {$ENDIF} iByte); + End; + 2 : Begin + AddPointer ({$IFDEF MPLPARSER} 'cfgsyspath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.SystemPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgdatapath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.DataPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfglogspath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.LogsPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgmsgspath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.MsgsPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgattpath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.AttachPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgqwkpath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.QwkPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgmenupath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Session.Lang.MenuPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgtextpath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Session.Lang.TextPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgmpepath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Config.ScriptPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgtemppath', {$ENDIF} iString, mysMaxPathSize, {$IFNDEF MPLPARSER} @Session.TempPath {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgtimeout', {$ENDIF} iWord, 4, {$IFNDEF MPLPARSER} @Config.Inactivity {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfgseeinvis', {$ENDIF} iString, 20, {$IFNDEF MPLPARSER} @Config.AcsSeeInvis {$ELSE} NIL {$ENDIF}); + AddPointer ({$IFDEF MPLPARSER} 'cfginettnmax', {$ENDIF} iByte, 1, {$IFNDEF MPLPARSER} @Config.INetTNMax {$ELSE} NIL {$ENDIF}); + End; + 3 : Begin + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarMBase := X + 1; {$ENDIF} + + AddVar ({$IFDEF MPLPARSER} 'mbaseindex', {$ENDIF} iInteger); + AddStr ({$IFDEF MPLPARSER} 'mbasename', {$ENDIF} iString, 40); + AddStr ({$IFDEF MPLPARSER} 'mbaseacs', {$ENDIF} iString, 20); + AddStr ({$IFDEF MPLPARSER} 'mbaseracs', {$ENDIF} iString, 20); + AddStr ({$IFDEF MPLPARSER} 'mbasepacs', {$ENDIF} iString, 20); + AddStr ({$IFDEF MPLPARSER} 'mbasesacs', {$ENDIF} iString, 20); + End; + 4 : Begin + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarMGroup := X + 1; {$ENDIF} + + AddStr ({$IFDEF MPLPARSER} 'mgroupname', {$ENDIF} iString, 30); + AddStr ({$IFDEF MPLPARSER} 'mgroupacs', {$ENDIF} iString, 30); + AddVar ({$IFDEF MPLPARSER} 'mgrouphidden', {$ENDIF} iBool); + End; + 5 : Begin + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarFBase := X + 1; {$ENDIF} + + AddStr ({$IFDEF MPLPARSER} 'fbasename', {$ENDIF} iString, 40); + AddStr ({$IFDEF MPLPARSER} 'fbaseacs', {$ENDIF} iString, 30); + End; + 6 : Begin + {$IFNDEF MPLPARSER} TInterpEngine(S).IdxVarFGroup := X + 1; {$ENDIF} + + AddStr ({$IFDEF MPLPARSER} 'fgroupname', {$ENDIF} iString, 30); + AddStr ({$IFDEF MPLPARSER} 'fgroupacs', {$ENDIF} iString, 30); + AddVar ({$IFDEF MPLPARSER} 'fgrouphidden', {$ENDIF} iBool); + End; + End; +End; diff --git a/mystic/mpl_execute.pas b/mystic/mpl_execute.pas new file mode 100644 index 0000000..7c90392 --- /dev/null +++ b/mystic/mpl_execute.pas @@ -0,0 +1,2171 @@ +Unit MPL_Execute; + +{$I M_OPS.PAS} + +Interface + +Uses + DOS, + MPL_FileIO, + BBS_Common; + +{$I MPL_TYPES.PAS} + +Const + mplExecuteBuffer = 8 * 1024; + +Type + TInterpEngine = Class + Owner : Pointer; + ErrStr : String; + ErrNum : Byte; + DataFile : PCharFile; + CurVarNum : Word; + CurVarID : Word; + CurRecNum : Word; + VarData : VarDataRec; + RecData : RecDataRec; + Ch : Char; + W : Word; + IoError : LongInt; + ReloadMenu : Boolean; + DirInfo : SearchRec; + IdxVarDir : Word; + IdxVarUser : Word; + IdxVarMBase : Word; + IdxVarMGroup : Word; + IdxVarFBase : Word; + IdxVarFGroup : Word; + ParamsStr : String; + MPEName : String; + Done : Boolean; + ExitProc : Boolean; + SavedMCI : Boolean; + SavedGroup : Boolean; + SavedArrow : Boolean; + + Function GetErrorMsg : String; + Procedure Error (Err: Byte; Str: String); + Procedure MoveToPos (Num: LongInt); + Procedure SkipBlock; + Function CurFilePos : LongInt; + Procedure NextChar; + Procedure NextWord; + Procedure PrevChar; + Function GetDataPtr (VN: Word; Var A: TArrayInfo) : Pointer; + Function GetDataSize (VarNum: Word) : Word; + Function FindVariable (ID: Word) : Word; + Procedure CheckArray (VN: Word; Var A: TArrayInfo); + Function GetNumber (VN: Word; Var A: TArrayInfo) : Real; + Function RecastNumber (Var Num; T: TIdentTypes) : Real; + + Function EvaluateNumber : Real; + Function EvaluateString : String; + Function EvaluateBoolean : Boolean; + + Procedure SetString (VarNum: Word; Var A: TArrayInfo; Str: String); + Procedure SetNumber (VN: Word; R: Real; Var A: TArrayInfo); + Procedure SetVariable (VarNum: Word); + + Function DefineVariable : LongInt; + Procedure DefineProcedure; + Procedure DefineRecord; + + Procedure StatementRepeatUntil; + Function StatementIfThenElse : Byte; + Function StatementCase : Byte; + Procedure StatementForLoop; + Procedure StatementWhileDo; + + Function ExecuteProcedure (DP: Pointer) : TIdentTypes; + Function ExecuteBlock (StartVar, StartRec: Word) : Byte; + + // BBS DATA ACCESS FUNCTIONS + Procedure FileReadLine (Var F: File; Var Str: String); + Procedure FileWriteLine (Var F: File; Str: String); + + Procedure GetUserVars (Var U: RecUser); + Function GetUserRecord (Num: LongInt) : Boolean; + Procedure GetMBaseVars (Var M: MBaseRec); + Function GetMBaseRecord (Num: LongInt) : Boolean; + Procedure GetMGroupVars (Var G: RecGroup); + Function GetMGroupRecord (Num: LongInt) : Boolean; + Procedure GetFBaseVars (Var F: FBaseRec); + Function GetFBaseRecord (Num: LongInt) : Boolean; + Procedure GetFGroupVars (Var G: RecGroup); + Function GetFGroupRecord (Num: LongInt) : Boolean; + + Constructor Create (O: Pointer); + Destructor Destroy; Override; + Function Execute (FN: String) : Byte; + End; + +Function ExecuteMPL (Owner: Pointer; Str: String) : Byte; + +Implementation + +Uses + m_Bits, + m_Strings, + m_DateTime, + m_Types, + m_FileIO, + BBS_Core, + BBS_IO, + BBS_General; + +{$I MPL_COMMON.PAS} + +Procedure TInterpEngine.GetUserVars (Var U: RecUser); +Begin + Move (U.PermIdx, VarData[IdxVarUser ]^.Data^, SizeOf(U.PermIdx)); + Move (U.RealName, VarData[IdxVarUser + 1 ]^.Data^, SizeOf(U.RealName)); + Move (U.Handle, VarData[IdxVarUser + 2 ]^.Data^, SizeOf(U.Handle)); + Move (U.Address, VarData[IdxVarUser + 3 ]^.Data^, SizeOf(U.Address)); + Move (U.Security, VarData[IdxVarUser + 4 ]^.Data^, SizeOf(U.Security)); + Move (U.Gender, VarData[IdxVarUser + 5 ]^.Data^, SizeOf(U.Gender)); + Move (U.FirstOn, VarData[IdxVarUser + 6 ]^.Data^, SizeOf(U.FirstOn)); + Move (U.LastOn, VarData[IdxVarUser + 7 ]^.Data^, SizeOf(U.LastOn)); + Move (U.DateType, VarData[IdxVarUser + 8 ]^.Data^, SizeOf(U.DateType)); + Move (U.Calls, VarData[IdxVarUser + 9 ]^.Data^, SizeOf(U.Calls)); + Move (U.Password, VarData[IdxVarUser + 10]^.Data^, SizeOf(U.Password)); + Move (U.Flags, VarData[IdxVarUser + 11]^.Data^, SizeOf(U.Flags)); +End; + +Function TInterpEngine.GetUserRecord (Num: LongInt) : Boolean; +Var + F : File; + U : RecUser; +Begin + Result := False; + + Assign (F, Config.DataPath + 'users.dat'); + If Not ioReset(F, SizeOf(RecUser), fmRWDN) Then Exit; + + If ioSeek(F, Pred(Num)) And (ioRead(F, U)) Then Begin + GetUserVars(U); + Result := True; + End; + + Close (F); +End; + +Procedure TInterpEngine.GetMBaseVars (Var M: MBaseRec); +Begin + Move (M.Index, VarData[IdxVarMBase ]^.Data^, SizeOf(M.Index)); + Move (M.Name, VarData[IdxVarMBase + 1 ]^.Data^, SizeOf(M.Name)); + Move (M.ACS, VarData[IdxVarMBase + 2 ]^.Data^, SizeOf(M.ACS)); + Move (M.ReadACS, VarData[IdxVarMBase + 3 ]^.Data^, SizeOf(M.ReadACS)); + Move (M.PostACS, VarData[IdxVarMBase + 4 ]^.Data^, SizeOf(M.PostACS)); + Move (M.SysopACS, VarData[IdxVarMBase + 5 ]^.Data^, SizeOf(M.SysopACS)); +End; + +Function TInterpEngine.GetMBaseRecord (Num: LongInt) : Boolean; +Var + F : File; + M : MBaseRec; +Begin + Result := False; + + Assign (F, Config.DataPath + 'mbases.dat'); + If Not ioReset(F, SizeOf(MBaseRec), fmRWDN) Then Exit; + + If ioSeek(F, Num) And (ioRead(F, M)) Then Begin + GetMBaseVars(M); + Result := True; + End; + + Close (F); +End; + +Procedure TInterpEngine.GetMGroupVars (Var G: RecGroup); +Begin + Move (G.Name, VarData[IdxVarMGroup ]^.Data^, SizeOf(G.Name)); + Move (G.ACS, VarData[IdxVarMGroup + 1 ]^.Data^, SizeOf(G.ACS)); + Move (G.Hidden, VarData[IdxVarMGroup + 2 ]^.Data^, SizeOf(G.Hidden)); +End; + +Function TInterpEngine.GetMGroupRecord (Num: LongInt) : Boolean; +Var + F : File; + G : RecGroup; +Begin + Result := False; + + Assign (F, Config.DataPath + 'groups_g.dat'); + If Not ioReset(F, SizeOf(RecGroup), fmRWDN) Then Exit; + + If ioSeek(F, Pred(Num)) And (ioRead(F, G)) Then Begin + GetMGroupVars(G); + Result := True; + End; + + Close (F); +End; + +Procedure TInterpEngine.GetFBaseVars (Var F: FBaseRec); +Begin + Move (F.Name, VarData[IdxVarFBase ]^.Data^, SizeOf(F.Name)); + Move (F.ListACS, VarData[IdxVarFBase + 1 ]^.Data^, SizeOf(F.ListACS)); +End; + +Function TInterpEngine.GetFBaseRecord (Num: LongInt) : Boolean; +Var + F : File; + FB : FBaseRec; +Begin + Result := False; + + Assign (F, Config.DataPath + 'fbases.dat'); + If Not ioReset(F, SizeOf(FBaseRec), fmRWDN) Then Exit; + + If ioSeek(F, Pred(Num)) And (ioRead(F, FB)) Then Begin + GetFBaseVars(FB); + Result := True; + End; + + Close (F); +End; + +Procedure TInterpEngine.GetFGroupVars (Var G: RecGroup); +Begin + Move (G.Name, VarData[IdxVarFGroup ]^.Data^, SizeOf(G.Name)); + Move (G.ACS, VarData[IdxVarFGroup + 1 ]^.Data^, SizeOf(G.ACS)); + Move (G.Hidden, VarData[IdxVarFGroup + 2 ]^.Data^, SizeOf(G.Hidden)); +End; + +Function TInterpEngine.GetFGroupRecord (Num: LongInt) : Boolean; +Var + F : File; + G : RecGroup; +Begin + Result := False; + + Assign (F, Config.DataPath + 'groups_f.dat'); + If Not ioReset(F, SizeOf(RecGroup), fmRWDN) Then Exit; + + If ioSeek(F, Pred(Num)) And (ioRead(F, G)) Then Begin + GetFGroupVars(G); + Result := True; + End; + + Close (F); +End; + +Constructor TInterpEngine.Create (O: Pointer); +Begin + Inherited Create; + + Owner := O; + ErrNum := 0; + ErrStr := ''; + Ch := #0; + W := 0; +End; + +Destructor TInterpEngine.Destroy; +Var + Count : LongInt; +Begin + For Count := 1 to CurVarNum Do Begin + If (VarData[Count]^.Kill) And (VarData[Count]^.Data <> NIL) Then + FreeMem(VarData[Count]^.Data, VarData[Count]^.DataSize); + + Dispose(VarData[Count]); + End; + + For Count := 1 to CurRecNum Do + Dispose(RecData[Count]); + + CurVarNum := 0; + CurRecNum := 0; + + Inherited Destroy; +End; + +Function TInterpEngine.GetErrorMsg : String; +Begin + Result := ''; + + Case ErrNum of + mpxEndOfFile : Result := 'Unexpected end of file'; + mpxInvalidFile : Result := 'Invalid executable: ' + ErrStr; + mpxVerMismatch : Result := 'Version mismatch: ' + ErrStr + ' / ' + mplVersion; + mpxUnknownOp : Result := 'Unknown Token: ' + ErrStr; + mpxMultiInit : Result := 'Unable to initialize variable'; + mpxDivisionByZero : Result := 'Division by zero'; + mpxMathematical : Result := 'Parsing error'; + End; +End; + +Procedure TInterpEngine.Error (Err: Byte; Str: String); +Begin + If ErrNum > 0 Then Exit; + + ErrNum := Err; + ErrStr := Str; +End; + +Procedure TInterpEngine.MoveToPos (Num: LongInt); +Begin + DataFile^.Seek (Num + mplVerLength); +End; + +Function TInterpEngine.CurFilePos : LongInt; +Begin + Result := DataFile^.FilePos - mplVerLength; +End; + +Procedure TInterpEngine.NextChar; +Begin + Ch := DataFile^.Read; +End; + +Procedure TInterpEngine.NextWord; +Var + Res : LongInt; +Begin + DataFile^.BlockRead (W, 2, Res); +End; + +Procedure TInterpEngine.PrevChar; +Begin + MoveToPos (CurFilePos - 1); +End; + +Function TInterpEngine.FindVariable (ID: Word) : Word; +Var + Count : LongInt; +Begin + Result := 0; + Count := CurVarNum; + + If CurVarNum = 0 Then Exit; + + Repeat + If VarData[Count]^.VarID = ID Then Begin + Result := Count; + Exit; + End; + + Dec (Count); + Until (Count = 0); +End; + +Function TInterpEngine.GetDataPtr (VN: Word; Var A: TArrayInfo) : Pointer; +Begin + With VarData[VN]^ Do + Case ArrPos of + 0 : Result := Data; + 1 : Result := @Data^[VarSize * (A[1] - 1) + 1]; + 2 : Result := @Data^[VarSize * ((A[1] - 1) * ArrDim[2] + A[2])]; + 3 : Result := @Data^[VarSize * ((A[1] - 1) * (ArrDim[2] * ArrDim[3]) + (A[2] - 1) * ArrDim[3] + A[3])]; + End; +End; + +Procedure TInterpEngine.CheckArray (VN: Word; Var A: TArrayInfo); +Var + Count : Word; +Begin + For Count := 1 to mplMaxArrayDem Do A[Count] := 1; + + If VarData[VN]^.ArrPos = 0 Then Exit; + + For Count := 1 to VarData[VN]^.ArrPos Do + A[Count] := Trunc(EvaluateNumber); +End; + +Function TInterpEngine.GetNumber(VN: Word; Var A: TArrayInfo) : Real; +Begin + Case VarData[VN]^.vType of + iByte : Result := Byte(GetDataPtr(VN, A)^); + iShort : Result := ShortInt(GetDataPtr(VN, A)^); + iWord : Result := Word(GetDataPtr(VN, A)^); + iInteger : Result := Integer(GetDataPtr(VN, A)^); + iLongInt : Result := LongInt(GetDataPtr(VN, A)^); + iReal : Result := Real(GetDataPtr(VN, A)^); + End; +End; + +Function TInterpEngine.RecastNumber (Var Num; T: TIdentTypes) : Real; +Begin + Case T of + iByte : Result := Byte(Num); + iShort : Result := ShortInt(Num); + iWord : Result := Word(Num); + iInteger : Result := Integer(Num); + iLongInt : Result := LongInt(Num); + iReal : Result := Real(Num); + End; +End; + +Function TInterpEngine.EvaluateNumber : Real; +Var + CheckChar : Char; + VarNum : Word; + PowerRes : Real; + + Procedure ParseNext; + Begin + NextChar; + If Ch = Char(opCloseNum) Then CheckChar := ^M Else CheckChar := Ch; + End; + + Function AddSubtract : Real; + Var + OpChar : Char; + + Function MultiplyDivide : Real; + Var + OpChar : Char; + + Function Power : Real; + + Function SignedOp : Real; + + Function UnsignedOp : Real; + Var + Start : LongInt; + ArrayInfo : TArrayInfo; + NumStr : String; + Begin + Case TTokenOpsRec(Byte(CheckChar)) of + opLeftParan : Begin + ParseNext; + Result := AddSubtract; + ParseNext; + End; + opVariable : Begin + NextWord; + VarNum := FindVariable(w); + CheckArray(VarNum, ArrayInfo); + Result := GetNumber(VarNum, ArrayInfo); + ParseNext; + End; + opProcExec : Begin + Result := RecastNumber(Result, ExecuteProcedure(@Result)); + ParseNext; + End; + Else + NumStr := ''; + + Repeat + NumStr := NumStr + CheckChar; + ParseNext; + Until Not (CheckChar in ['0'..'9', '.', 'E']); + + Val(NumStr, Result, Start); + End; + End; + + Begin + If CheckChar = '-' Then Begin + ParseNext; + Result := -UnsignedOp; + End Else + Result := UnsignedOp; + End; + + Begin + Result := SignedOp; + + While CheckChar = '^' Do Begin + ParseNext; + If Result <> 0 Then + Result := Exp(Ln(Abs(Result)) * SignedOp) + Else + Result := 0; + End; + End; + + Begin + Result := Power; + While CheckChar in ['%','*','/'] Do Begin + OpChar := CheckChar; + ParseNext; + Case OpChar of + '%' : Result := Trunc(Result) MOD Trunc(Power); + '*' : Result := Result * Power; + '/' : Begin + PowerRes := Power; + If PowerRes = 0 Then + Error (mpxDivisionByZero, '') + Else + Result := Result / PowerRes; + End; + End; + End; + End; + + Begin + Result := MultiplyDivide; + + While CheckChar in ['+','-','&','|','@','<','>'] Do Begin + OpChar := CheckChar; + ParseNext; + Case OpChar of + '+' : Result := Result + MultiplyDivide; + '-' : Result := Result - MultiplyDivide; + '&' : Result := Trunc(Result) AND Trunc(MultiplyDivide); + '|' : Result := Trunc(Result) OR Trunc(MultiplyDivide); + '@' : Result := Trunc(Result) XOR Trunc(MultiplyDivide); + '<' : Result := Trunc(Result) SHL Trunc(MultiplyDivide); + '>' : Result := Trunc(Result) SHR Trunc(MultiplyDivide); + End; + End; + End; +Begin + NextChar; + ParseNext; + Result := AddSubtract; +End; + +Function TInterpEngine.EvaluateString : String; +Var + VarNum : Word; + ArrayData : TArrayInfo; + Res : LongInt; +Begin + Result := ''; + + NextChar; + + Case TTokenOpsRec(Byte(Ch)) of + opVariable : Begin + NextWord; + VarNum := FindVariable(W); + CheckArray (VarNum, ArrayData); + If VarData[VarNum].vType = iChar Then Begin + Result[0] := #1; + Result[1] := Char(GetDataPtr(VarNum, ArrayData)^); + End Else + Result := String(GetDataPtr(VarNum, ArrayData)^); + End; + opOpenString : Begin + NextChar; + Result[0] := Ch; + DataFile^.BlockRead (Result[1], Byte(Ch), Res); + End; + opProcExec : Case ExecuteProcedure(@Result) of + iChar : Begin // convert to string if its a char + Result[1] := Result[0]; + Result[0] := #1; + End; + End; + End; + + NextChar; + + If Ch = Char(opStrArray) Then Begin + Result := Result[Trunc(EvaluateNumber)]; + NextChar; + End; + + If Ch = Char(opStrAdd) Then + Result := Result + EvaluateString + Else + PrevChar; +End; + +Function TInterpEngine.EvaluateBoolean : Boolean; +Type + tOp = ( + tOpNone, + tOpEqual, + tOpNotEqual, + tOpGreater, + tOpLess, + tOpEqGreat, + tOpEqLess + ); + +Var + VarNum : Word; + VarType1 : TIdentTypes; + VarType2 : TIdentTypes; + OpType : tOp; + GotA : Boolean; + GotB : Boolean; + BooleanA : Boolean; + BooleanB : Boolean; + IsNot : Boolean; + RealA : Real; + RealB : Real; + StringA : String; + StringB : String; + ArrayData : TArrayInfo; +Begin +// set default result? + VarType1 := iNone; + VarType2 := iNone; + GotA := False; + GotB := False; + OpType := tOpNone; + IsNot := False; + + Repeat + NextChar; + +// put these in numerical order... + Case TTokenOpsRec(Byte(Ch)) of + opLeftParan : Begin + BooleanA := EvaluateBoolean; + VarType1 := iBool; + GotA := True; + NextChar; + End; + opVariable : Begin + NextWord; + VarNum := FindVariable(W); + CheckArray(VarNum, ArrayData); + VarType1 := VarData[VarNum]^.vType; + + If VarType1 = iBool Then + BooleanA := ByteBool(GetDataPtr(VarNum, ArrayData)^) + Else + If (VarType1 in vStrings) Then Begin + NextChar; + If Ch = Char(opStrArray) Then + StringA := String(GetDataPtr(VarNum, ArrayData)^)[Trunc(EvaluateNumber)] + Else Begin + PrevChar; + If VarData[VarNum]^.vType = iChar Then Begin + StringA[0] := #1; + StringA[1] := Char(GetDataPtr(VarNum, ArrayData)^); + End Else + StringA := String(GetDataPtr(VarNum, ArrayData)^); + End; + End Else + If VarType1 in vNums Then + RealA := GetNumber(VarNum, ArrayData); // evalnumber here + + GotA := True; + End; + opProcExec : Begin + VarType1 := ExecuteProcedure(@StringA); + If VarType1 = iBool Then BooleanA := Boolean(Byte(StringA[0])) else + If VarType1 in vNums Then RealA := RecastNumber(StringA, VarType1) else + if VarType1 = iChar Then Begin + StringA[1] := StringA[0]; + StringA[0] := #1; + End; + + GotA := True; + End; + opTrue : Begin // we can combine true/false here... + BooleanA := True; + VarType1 := iBool; + GotA := True; + End; + opFalse : Begin + BooleanA := False; + VarType1 := iBool; + GotA := True; + End; + opOpenString : Begin + PrevChar; + StringA := EvaluateString; + VarType1 := iString; + GotA := True; + End; + opOpenNum : Begin + PrevChar; + RealA := EvaluateNumber; + VarType1 := iReal; + GotA := True; + End; + opNot : IsNot := Not IsNot; + End; + Until (ErrNum <> 0) or GotA; + + If ErrNum <> 0 Then Exit; + + NextChar; + + // we shouldnt even need this... just use the actual tokens...??? + Case TTokenOpsRec(Byte(Ch)) of + opEqual : OpType := tOpEqual; + opNotEqual : OpType := tOpNotEqual; + opGreater : OpType := tOpGreater; + opLess : OpType := tOpLess; + opEqGreat : OpType := tOpEqGreat; + opEqLess : OpType := tOpEqLess; + Else + Result := BooleanA; + PrevChar; + End; + + If OpType <> tOpNone Then Begin + Repeat + NextChar; + + Case TTokenOpsRec(Byte(Ch)) of + opLeftParan : Begin + BooleanB := EvaluateBoolean; + VarType2 := iBool; + GotB := True; + NextChar; + End; + opVariable : Begin + NextWord; + VarNum := FindVariable(w); + CheckArray (VarNum, ArrayData); + VarType2 := VarData[VarNum]^.vType; + + If VarType2 = iBool Then + BooleanB := ByteBool(GetDataPtr(VarNum,ArrayData)^) + Else + If (VarType2 in vStrings) Then Begin + NextChar; + If Ch = Char(opStrArray) Then + StringB := String(GetDataPtr(VarNum, ArrayData)^)[Trunc(EvaluateNumber)] + Else Begin + PrevChar; + If VarData[VarNum]^.vType = iChar Then Begin + StringB[0] := #1; + StringB[1] := Char(GetDataPtr(VarNum, ArrayData)^); + End Else + StringB := String(GetDataPtr(VarNum, ArrayData)^); + End; + End Else + If VarType2 in vNums Then + RealB := GetNumber(VarNum, ArrayData); + + GotB := True; + End; + opProcExec : Begin + VarType2 := ExecuteProcedure(@StringB); + If VarType2 = iBool Then BooleanB := Boolean(Byte(StringB[0])) Else + If VarType2 in vNums Then RealB := RecastNumber(StringB, VarType2) Else + if VarType2 = iChar Then Begin + StringB[1] := StringB[0]; + StringB[0] := #1; + End; + + GotB := True; + End; + opTrue : Begin + BooleanB := True; + VarType2 := iBool; + GotB := True; + End; + opFalse : Begin + BooleanB := False; + VarType2 := iBool; + GotB := True; + End; + opOpenString : Begin + PrevChar; + StringB := EvaluateString; + VarType2 := iString; + GotB := True; + End; + opOpenNum : Begin + PrevChar; + RealB := EvaluateNumber; + VarType2 := iReal; + GotB := True; + End; + End; + Until (ErrNum <> 0) or GotB; + + If ErrNum <> 0 Then Exit; + + Result := False; + + Case OpType of + tOpEqual : If (VarType1 in vStrings) Then + Result := StringA = StringB + Else + If VarType1 = iBool Then + Result := BooleanA = BooleanB + Else + Result := RealA = RealB; + tOpNotEqual : If (VarType1 in vStrings) Then Result := StringA <> StringB Else + If VarType1 = iBool Then Result := BooleanA <> BooleanB Else + Result := RealA <> RealB; + tOpGreater : If (VarType1 in vStrings) Then Result := StringA > StringB Else + If VarType1 = iBool Then Result := BooleanA > BooleanB Else + Result := RealA > RealB; + tOpLess : If (VarType1 in vStrings) Then Result := StringA < StringB Else + If VarType1 = iBool Then Result := BooleanA < BooleanB Else + Result := RealA < RealB; + tOpEqGreat : If (VarType1 in vStrings) Then Result := StringA >= StringB Else + If VarType1 = iBool Then Result := BooleanA >= BooleanB Else + Result := RealA >= RealB; + tOpEqLess : If (VarType1 in vStrings) Then Result := StringA <= StringB Else + If VarType1 = iBool Then Result := BooleanA <= BooleanB Else + Result := RealA <= RealB; + End; + End; + + If IsNot Then Result := Not Result; + + NextChar; + + Case TTokenOpsRec(Byte(Ch)) of + opAnd : Result := EvaluateBoolean And Result; + opOr : Result := EvaluateBoolean Or Result; + Else + PrevChar; + End; +End; + +Procedure TInterpEngine.SetString (VarNum: Word; Var A: TArrayInfo; Str: String); +Begin + If VarData[VarNum].vType = iString Then Begin + If Ord(Str[0]) >= VarData[VarNum]^.VarSize Then + Str[0] := Chr(VarData[VarNum]^.VarSize - 1); + + Move (Str, GetDataPtr(VarNum, A)^, VarData[VarNum]^.VarSize); + End Else + Move (Str[1], GetDataPtr(VarNum, A)^, 1); +End; + +Procedure TInterpEngine.SetVariable (VarNum: Word); +Var + ArrayData : TArrayInfo; + Target : Byte; + TempStr : String; +Begin + CheckArray (VarNum, ArrayData); + + Case VarData[VarNum]^.vType of + iChar, + iString: Begin + NextChar; + + If Ch = Char(opStrArray) Then Begin + TempStr := String(GetDataPtr(VarNum, ArrayData)^); + Target := Byte(Trunc(EvaluateNumber)); + TempStr[Target] := EvaluateString[1]; + + SetString (VarNum, ArrayData, TempStr); + End Else Begin + PrevChar; + SetString (VarNum, ArrayData, EvaluateString); + End; + End; + iByte : Byte(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber); + iShort : ShortInt(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber); + iWord : Word(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber); + iInteger : Integer(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber); + iLongInt : LongInt(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber); + iReal : Real(GetDataPtr(VarNum, ArrayData)^) := EvaluateNumber; + iBool : ByteBool(GetDataPtr(VarNum, ArrayData)^) := EvaluateBoolean; + End; +End; + +Procedure TInterpEngine.SetNumber (VN: Word; R: Real; Var A: TArrayInfo); +Begin + Case VarData[VN]^.vType of + iByte : Byte(GetDataPtr(VN, A)^) := Trunc(R); + iShort : ShortInt(GetDataPtr(VN, A)^) := Trunc(R); + iWord : Word(GetDataPtr(VN, A)^) := Trunc(R); + iInteger : Integer(GetDataPtr(VN, A)^) := Trunc(R); + iLongInt : LongInt(GetDataPtr(VN, A)^) := Trunc(R); + iReal : Real(GetDataPtr(VN, A)^) := R; + end; +end; + +Function TInterpEngine.GetDataSize (VarNum: Word) : Word; +Var + Count : Word; +Begin + With VarData[VarNum]^ Do Begin + Result := VarSize; + For Count := 1 To ArrPos Do + Result := Result * ArrDim[Count]; + End; +End; + +Function TInterpEngine.DefineVariable : LongInt; +Var + VarType : TIdentTypes; + NumVars : Word; + SavedVar : Word; + StrSize : Word; + Count : Word; + ArrayPos : Word; + ArrayData : TArrayInfo; +Begin + Result := 0; + + NextChar; + + VarType := cVarType(Ch); + + NextChar; + + StrSize := 256; + ArrayPos := 0; + + For Count := 1 To mplMaxArrayDem Do ArrayData[Count] := 1; + + If Ch = Char(opStrSize) Then Begin + StrSize := Trunc(EvaluateNumber) + 1; + NextChar; + End; + + If Ch = Char(opArrDef) Then Begin + NextWord; + ArrayPos := W; + For Count := 1 to ArrayPos Do ArrayData[Count] := Trunc(EvaluateNumber); + End; + + NextWord; + + NumVars := W; + SavedVar := CurVarNum + 1; + + For Count := 1 to NumVars Do + If ErrNum = 0 Then Begin + NextWord; + + If FindVariable(W) > 0 Then Begin + Error (mpxMultiInit, ''); + Exit; + End; + + Inc (CurVarNum); + New (VarData[CurVarNum]); + + With VarData[CurVarNum]^ Do Begin + VarID := W; + vType := VarType; + NumParams := 0; + ProcPos := 0; + + If VarType = iString Then + VarSize := StrSize + Else + VarSize := xVarSize(VarType); + + Kill := True; + ArrPos := ArrayPos; + ArrDim := ArrayData; + DataSize := GetDataSize(CurVarNum); + Result := DataSize; + + GetMem (Data, DataSize); + FillChar (Data^, DataSize, 0); + End; + End; + + NextChar; + + If Ch = Char(OpEqual) Then Begin + SetVariable(SavedVar); + For Count := SavedVar + 1 To CurVarNum Do + Move (VarData[SavedVar]^.Data^, VarData[Count]^.Data^, VarData[SavedVar]^.DataSize); + End Else + PrevChar; +End; + +Procedure TInterpEngine.FileReadLine (Var F: File; Var Str: String); +Var + Buf : String; + BR : SmallInt; + Count : Byte; + SP : LongInt; +Begin + Str := ''; + SP := FilePos(F); + Count := 1; + + BlockRead (F, Buf[1], 255, BR); + + While Count <= BR Do Begin + Inc (SP); + + If Buf[Count] = #10 Then Break; + If Buf[Count] <> #13 Then + Str := Str + Buf[Count]; + + If Count = 255 Then Begin + BlockRead (F, Buf[1], 255, BR); + Count := 0; + End; + + Inc (Count); + End; + + Seek (F, SP); + + IoError := IoResult; +End; + +Procedure TInterpEngine.FileWriteLine (Var F: File; Str: String); +Begin + {$IFDEF WIN32} + Str := Str + #13#10; + {$ENDIF} + {$IFDEF UNIX} + Str := Str + #10; + {$ENDIF} + + BlockWrite (F, Str[1], Ord(Str[0])); + + IoError := IoResult; +End; + +Function TInterpEngine.ExecuteProcedure (DP: Pointer) : TIdentTypes; +// okay... change this to: +// array[1..mplmaxprocparams] of record +// vsize : word; +// vdata : pointer; +// end; +// VAR passing: stores dataptr to passed variable -- DONE +// regular : creates var and stores its pointer into vdata -- TODO +// doing this will reduce memory usage and make things even harder to +// understand. +// this stuff really needs to be cleaned up before records are fully +// added +Type + TParamInfo = Array[1..mplMaxProcParams] of Record +// vType : TIdentTypes; + vSize : Word; //do we really nede this? can get size from vType + vID : Word; + vData : PStack; + Case TIdentTypes of // this all needs to go... push to vData + iChar : (C : Char); + iString : (S : String); + iByte : (B : Byte); + iShort : (H : ShortInt); + iWord : (W : Word); + iInteger : (I : Integer); + iLongInt : (L : LongInt); + iReal : (R : Real); + iBool : (O : Boolean); + End; + +Var + VarNum : Word; + Count : Word; + ProcID : Word; + SavedVar : Word; + Param : TParamInfo; + TempStr : String; + TempBool : Boolean; + TempByte : Byte; + TempLong : LongInt; + TempChar : Char; + TempInt : SmallInt; + Sub : LongInt; + ArrayData : TArrayInfo; + + Procedure Store (Var Dat; Siz: Word); + Begin + If DP <> NIL Then Move (Dat, DP^, Siz); + End; + +Begin +// no default result value set here + NextWord; + + ProcID := W; + VarNum := FindVariable(ProcID); + + For Count := 1 to VarData[VarNum]^.NumParams Do Begin + With VarData[VarNum]^ Do Begin + If Params[Count] = UpCase(Params[Count]) Then Begin + + // its a VAR type parameter, so find the variable + // and directly map the data pointer to the passed vars + // data pointer + + NextWord; + + Param[Count].vID := FindVariable(W); + CheckArray(Param[Count].vID, ArrayData); + + Param[Count].vData := GetDataPtr(Param[Count].vID, ArrayData); + + If VarData[Param[Count].vID]^.vType = iString Then + Param[Count].vSize := VarData[Param[Count].vID]^.VarSize; + End Else Begin + // this should getmem dataptr and store it there instead + // will save some memory but make calling functions below a bit more + // of a pain in the ass + Case Params[Count] of + 'c' : Begin + Param[Count].vSize := 1; + Param[Count].C := EvaluateString[1]; + End; + 's' : Begin + Param[Count].vSize := 256; + Param[Count].S := EvaluateString; + End; + 'b' : Param[Count].B := Trunc(EvaluateNumber); + 'h' : Param[Count].H := Trunc(EvaluateNumber); + 'w' : Param[Count].W := Trunc(EvaluateNumber); + 'i' : Param[Count].I := Trunc(EvaluateNumber); + 'l' : Param[Count].L := Trunc(EvaluateNumber); + 'r' : Param[Count].R := EvaluateNumber; + 'o' : Param[Count].O := EvaluateBoolean; + End; + End; + + NextChar; + End; + End; + + Result := VarData[VarNum]^.vType; + + // this means that its a physical procedure and not a variable + // or a predefined procedure from mpl_common. + + If VarData[VarNum]^.ProcPos > 0 Then Begin + Sub := CurFilePos; + SavedVar := CurVarNum; + + MoveToPos(VarData[VarNum]^.ProcPos); + + For Count := 1 to VarData[VarNum]^.NumParams Do Begin + Inc (CurVarNum); + New (VarData[CurVarNum]); + + With VarData[CurVarNum]^ Do Begin + VarID := VarData[VarNum]^.pID[Count]; + vType := cVarType(VarData[VarNum]^.Params[Count]); + NumParams := 0; + ProcPos := 0; + ArrPos := 0; + + If vType = iString Then + VarSize := Param[Count].vSize + Else + VarSize := xVarSize(vType); + + DataSize := GetDataSize(CurVarNum); + + If VarData[VarNum]^.Params[Count] = UpCase(VarData[VarNum]^.Params[Count]) Then Begin +// Data := VarData[Param[Count].vID]^.Data; + Data := Param[Count].vData; + Kill := False; + End Else Begin + GetMem (Data, DataSize); + + Case VarData[VarNum]^.Params[Count] of + 'c' : Char(Pointer(Data)^) := Param[Count].C; + 's' : Begin + If Ord(Param[Count].S[0]) >= VarSize Then + Param[Count].S[0] := Chr(VarSize - 1); + + Move (Param[Count].S, Data^, VarSize); + End; + 'b' : Byte(Pointer(Data)^) := Param[Count].B; + 'h' : ShortInt(Pointer(Data)^) := Param[Count].H; + 'w' : Word(Pointer(Data)^) := Param[Count].W; + 'i' : Integer(Pointer(Data)^) := Param[Count].I; + 'l' : LongInt(Pointer(Data)^) := Param[Count].L; + 'r' : Real(Pointer(Data)^) := Param[Count].R; + 'o' : Boolean(Pointer(Data)^) := Param[Count].O; + end; + + Kill := True; + End; + End; + End; + + If VarData[VarNum]^.vType <> iNone Then Begin + VarData[VarNum]^.DataSize := GetDataSize(VarNum); + VarData[VarNum]^.Kill := False; + + GetMem (VarData[VarNum]^.Data, VarData[VarNum]^.DataSize); + FillChar (VarData[VarNum]^.Data^, VarData[VarNum]^.DataSize, 0); + End; + + ExecuteBlock (SavedVar, CurRecNum); + + If ExitProc Then Begin + ExitProc := False; + Done := False; + End; + + If VarData[VarNum]^.vType <> iNone Then Begin + If DP <> NIL Then // force char into a string for DP + if VarData[VarNum]^.vType = iChar Then Begin + TempStr[0] := #1; + TempStr[1] := Char(Pointer(VarData[VarNum]^.Data)^); + + Move (TempStr, DP^, 2); + End Else + Move (VarData[VarNum]^.Data^, DP^, VarData[VarNum]^.DataSize); + + FreeMem(VarData[VarNum]^.Data, VarData[VarNum]^.DataSize); + + VarData[VarNum]^.DataSize := 0; + End; + + MoveToPos(Sub); + + Exit; + End; // end of custom procedure execution + + // its not a custom procedure, its a build in proc so lets do it + // this means that all of this param stuff will have to be redone + // if we change it to a dataptr. what effect will this have on + // execution speed? + + {$IFDEF LOGGING} + Session.SystemLog('MPE ProcID: ' + strI2S(ProcID)); + {$ENDIF} + + Case ProcID of + 0 : Session.io.OutFull(Param[1].S); + 1 : Session.io.OutFullLn(Param[1].S); + 2 : Session.io.AnsiClear; + 3 : Session.io.AnsiClrEOL; + 4 : Session.io.AnsiGotoXY(Param[1].B, Param[2].B); + 5 : Begin + TempByte := Screen.CursorX; + Store(TempByte, 1); + End; + 6 : Begin + TempByte := Screen.CursorY; + Store(TempByte, 1); + End; + 7 : Begin + TempStr := Session.io.GetKey; + Store(TempStr, 256); + End; + 8 : Begin + Session.io.BufFlush; + WaitMS(Param[1].L); + End; + 9 : Begin + TempLong := Random(Param[1].L); + Store (TempLong, 4); + End; + 10 : Begin + TempChar := Chr(Param[1].B); + Store (TempChar, 1); + End; + 11 : Begin + TempByte := Ord(Param[1].S[1]); + Store (TempByte, 1); + End; + 12 : Begin + TempStr := Copy(Param[1].S, Param[2].L, Param[3].L); + Store (TempStr, 256); + End; + 13 : Delete(String(Pointer(Param[1].vData)^), Param[2].L, Param[3].L); + 14 : Insert(Param[1].S, String(Pointer(Param[2].vData)^), Param[3].L); + 15 : Begin + TempLong := Length(Param[1].S); + Store (TempLong, 4); + End; + 16 : Begin + TempBool := Odd(Param[1].L); + Store (TempBool, 1); + End; + 17 : Begin + TempLong := Pos(Param[1].S, Param[2].S); + Store (TempLong, 4); + End; + 18 : Begin + {$IFDEF UNIX} + TempBool := Input.KeyPressed; + {$ELSE} + TempBool := Input.KeyPressed OR Session.Client.DataWaiting; + {$ENDIF} + Store (TempBool, 1); + Session.io.BufFlush; + End; + 19 : Begin + TempStr := strPadR(Param[1].S, Param[2].B, Param[3].S[1]); + Store (TempStr, 256); + End; + 20 : Begin + TempStr := strPadL(Param[1].S, Param[2].B, Param[3].S[1]); + Store (TempStr, 256); + End; + 21 : Begin + TempStr := strPadC(Param[1].S, Param[2].B, Param[3].S[1]); + Store (TempStr, 256); + End; + 22 : Begin + TempStr := strUpper(Param[1].S); + Store (TempStr, 256); + End; + 23 : Begin + TempStr := strLower(Param[1].S); + Store (TempStr, 256); + End; + 24 : Begin + TempStr := strRep(Param[1].S[1], Param[2].B); + Store (TempStr, 256); + End; + 25 : Begin + TempStr := strComma(Param[1].L); + Store (TempStr, 256); + End; + 26 : Begin + TempStr := strI2S(Param[1].L); + Store (TempStr, 256); + End; + 27 : Begin + TempLong := strS2I(Param[1].S); + Store (TempLong, 4); + End; + 28 : Begin + TempStr := strI2H(Param[1].L); + Store (TempStr, 256); + End; + 29 : Begin + TempStr := strWordGet(Param[1].B, Param[2].S, Param[3].S[1]); + Store (TempStr, 256); + End; + 30 : Begin + TempByte := strWordPos(Param[1].B, Param[2].S, Param[3].S[1]); + Store (TempByte, 1); + End; + 31 : Begin + TempByte := strWordCount(Param[1].S, Param[2].S[1]); + Store (TempByte, 1); + End; + 32 : Begin + TempStr := strStripL(Param[1].S, Param[2].S[1]); + Store (TempStr, 256); + End; + 33 : Begin + TempStr := strStripR(Param[1].S, Param[2].S[1]); + Store (TempStr, 256); + End; + 34 : Begin + TempStr := strStripB(Param[1].S, Param[2].S[1]); + Store (TempStr, 256); + End; + 35 : Begin + TempStr := strStripLow(Param[1].S); + Store (TempStr, 256); + End; + 36 : Begin + TempStr := strStripMCI(Param[1].S); + Store (TempStr, 256); + End; + 37 : Begin + TempByte := strMCILen(Param[1].S); + Store (TempByte, 1); + End; + 38 : Begin + TempStr := strInitials(Param[1].S); + Store (TempStr, 256); + End; + 39 : Begin + TempByte := strWrap(String(Pointer(Param[1].vData)^), String(Pointer(Param[2].vData)^), Param[3].B); + Store (TempByte, 1); + End; + 40 : Begin + TempStr := strReplace(Param[1].S, Param[2].S, Param[3].S); + Store (TempStr, 256); + End; + 41 : Begin + TempStr := GetEnv(Param[1].S); + Store (TempStr, 256); + End; + 42 : Begin + TempBool := FileExist(Param[1].S); + Store (TempBool, 1); + End; + 43 : FileErase(Param[1].S); + 44 : Begin + TempBool := FileDirExists(Param[1].S); + Store (TempBool, 1); + End; + 45 : Begin + TempLong := TimerMinutes; + Store (TempLong, 4); + End; + 46 : Begin + TempLong := TimerSeconds; + Store (TempLong, 4); + End; + 47 : Begin + TempLong := CurDateDos; + Store (TempLong, 4); + End; + 48 : Begin + TempLong := CurDateJulian; + Store (TempLong, 4); + End; + 49 : Begin + TempStr := DateDos2Str(Param[1].L, Param[2].B); + Store (TempStr, 256); + End; + 50 : Begin + TempStr := DateJulian2Str(Param[1].L, Param[2].B); + Store (TempStr, 256); + End; + 51 : Begin + TempLong := DateStr2Dos(Param[1].S); + Store (TempLong, 4); + End; + 52 : Begin + TempLong := DateStr2Julian(Param[1].S); + Store (TempLong, 4); + End; + 53 : DateG2J(Param[1].L, Param[2].L, Param[3].L, LongInt(VarData[Param[4].vID]^.Data)); + 54 : DateJ2G(Param[1].L, SmallInt(Pointer(Param[2].vData)^), SmallInt(Pointer(Param[3].vData)^), SmallInt(Pointer(Param[4].vData)^)); + 55 : Begin + TempBool := DateValid(Param[1].S); + Store (TempBool, 1); + End; + 56 : Begin + TempStr := TimeDos2Str(Param[1].L, Param[2].O); + Store (TempStr, 256); + End; + 57 : Begin + TempByte := DayOfWeek; + Store (TempByte, 1); + End; + 58 : Begin + TempLong := DaysAgo(Param[1].L); + Store (TempLong, 4); + End; + 59 : Begin + TempStr := JustFile(Param[1].S); + Store (TempStr, 256); + End; + 60 : Begin + TempStr := JustFileName(Param[1].S); + Store (TempStr, 256); + End; + 61 : Begin + TempStr := JustFileExt(Param[1].S); + Store (TempStr, 256); + End; + 62 : Begin + Assign (File(Pointer(Param[1].vData)^), Param[2].S); + FileMode := Param[3].L; + End; + 63 : Begin + Reset (File(Pointer(Param[1].vData)^), 1); + IoError := IoResult; + End; + 64 : Begin + ReWrite (File(Pointer(Param[1].vData)^), 1); + IoError := IoResult; + End; + 65 : Begin + Close (File(Pointer(Param[1].vData)^)); + IoError := IoResult; + End; + 66 : Begin + Seek (File(Pointer(Param[1].vData)^), Param[2].L); + IoError := IoResult; + End; + 67 : Begin + TempBool := Eof(File(Pointer(Param[1].vData)^)); + IoError := IoResult; + Store (TempBool, 1); + End; + 68 : Begin + TempLong := FileSize(File(Pointer(Param[1].vData)^)); + IoError := IoResult; + + Store (TempLong, 4); + End; + 69 : Begin + TempLong := FilePos(File(Pointer(Param[1].vData)^)); + IoError := IoResult; + + Store (TempLong, 4); + End; + 70 : Begin + BlockRead (File(Pointer(Param[1].vData)^), Param[2].vData^, Param[3].W); + IoError := IoResult; + End; + 71 : Begin + BlockWrite (File(Pointer(Param[1].vData)^), Param[2].vData^, Param[3].W); + IoError := IoResult; + End; + 72 : FileReadLine (File(Pointer(Param[1].vData)^), String(Pointer(Param[2].vData)^)); + 73 : FileWriteLine (File(Pointer(Param[1].vData)^), Param[2].S); + 74 : Begin + TempChar := PathChar; + Store (TempChar, 1); + End; + 75 : Begin + TempBool := BitCheck(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^); + + Store (TempBool, 1); + End; + 76 : BitToggle(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^); + 77 : BitSet(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^, Param[3].O); + 78 : Begin + FindFirst(Param[1].S, Param[2].W, DirInfo); + + Move (DirInfo.Name, VarData[IdxVarDir ]^.Data^, SizeOf(DirInfo.Name)); + Move (DirInfo.Size, VarData[IdxVarDir + 1]^.Data^, SizeOf(DirInfo.Size)); + Move (DirInfo.Time, VarData[IdxVarDir + 2]^.Data^, SizeOf(DirInfo.Time)); + Move (DirInfo.Attr, VarData[IdxVarDir + 3]^.Data^, SizeOf(DirInfo.Attr)); + End; + 79 : Begin + FindNext(DirInfo); + + Move (DirInfo.Name, VarData[IdxVarDir ]^.Data^, SizeOf(DirInfo.Name)); + Move (DirInfo.Size, VarData[IdxVarDir + 1]^.Data^, SizeOf(DirInfo.Size)); + Move (DirInfo.Time, VarData[IdxVarDir + 2]^.Data^, SizeOf(DirInfo.Time)); + Move (DirInfo.Attr, VarData[IdxVarDir + 3]^.Data^, SizeOf(DirInfo.Attr)); + End; + 80 : FindClose(DirInfo); + 81 : Begin + TempStr := JustPath(Param[1].S); + Store (TempStr, 256); + End; + 82 : Randomize; + 83 : Begin + TempByte := strWordCount(ParamsStr, ' '); + Store (TempByte, 1); + End; + 84 : Begin + If Param[1].B = 0 Then + TempStr := MPEName + Else + TempStr := strWordGet(Param[1].B, ParamsStr, ' '); + Store (TempStr, 256); + End; + 85 : Begin + TempByte := Screen.TextAttr; + Store (TempByte, 1); + End; + 86 : Session.io.AnsiColor(Param[1].B); + 87 : Begin + TempStr := DirSlash(Param[1].S); + Store (TempStr, 256); + End; + 88 : Begin + TempStr := strStripPipe(Param[1].S); + Store (TempStr, 256); + End; + 500 : Begin + TempStr := Session.io.GetInput(Param[1].B, Param[2].B, Param[3].B, Param[4].S); + Store (TempStr, 256); + Session.io.AllowArrow := True; + End; + 501 : Begin + TempBool := GetUserRecord(Param[1].L); + Store (TempBool, 1); + End; + 502 : Begin + TempChar := Session.io.OneKey(Param[1].S, Param[1].O); + Store (TempChar, 1); + End; + 503 : GetUserVars(Session.User.ThisUser); + 504 : Begin + TempBool := Session.io.GetYN(Param[1].S, True); + Store (TempBool, 1); + End; + 505 : Begin + TempBool := Session.io.GetYN(Param[1].S, False); + Store (TempBool, 1); + End; + 506 : Begin + Session.io.OutFile(Param[1].S, True, 0); + TempBool := Not Session.io.NoFile; + Store (TempBool, 1); + End; + 507 : Begin + TempBool := CopyFile(Param[1].S, Param[2].S); + Store (TempBool, 1); + End; + 508 : Begin + ReloadMenu := Session.Menu.ExecuteCommand(Param[1].S, Param[2].S); + Session.io.AllowArrow := True; + End; + 509 : Begin + Session.io.InMacroStr := Param[1].S; + Session.io.InMacroPos := 1; + Session.io.InMacro := Session.io.InMacroStr <> ''; + End; + 510 : Begin + TempBool := Session.User.Access(Param[1].S); + Store (TempBool, 1); + End; + 511 : Upgrade_User_Level(True, Session.User.ThisUser, Param[1].I); + 512 : Session.SetTimeLeft(Param[1].I); + 513 : Halt(0); + 514 : Begin + TempBool := GetMBaseRecord(Param[1].L); + Store (TempBool, 1); + End; + 515 : Begin + TempStr := Session.GetPrompt(Param[1].L); + Store (TempStr, 256); + End; + 516 : Begin + TempBool := GetMGroupRecord(Param[1].L); + Store (TempBool, 1); + End; + 517 : Session.io.PurgeInputBuffer; + 518 : Begin + TempBool := GetFBaseRecord(Param[1].L); + Store (TempBool, 1); + End; + 519 : Begin + TempBool := GetFGroupRecord(Param[1].L); + Store (TempBool, 1); + End; + 520 : Session.SystemLog(Param[1].S); + 521 : Session.io.AnsiMoveX(Param[1].B); + 522 : Session.io.AnsiMoveY(Param[1].B); + 523 : Session.io.OutPipe(Param[1].S); + 524 : Session.io.OutPipeLn(Param[1].S); + 525 : Session.io.OutRaw(Param[1].S); + 526 : Session.io.OutRawLn(Param[1].S); + 527 : Begin + TempStr := ''; + If Session.io.ParseMCI(False, Param[1].S) Then + TempStr := Session.io.LastMCIValue; + Store (TempStr, 256); + End; + 528 : Begin + TempInt := Session.TimeLeft; + Store (TempInt, 2); + End; + 529 : If Param[1].B < 10 Then Begin + Move (Session.io.ScreenInfo[Param[1].B].X, Param[2].vData^, 1); + Move (Session.io.ScreenInfo[Param[1].B].Y, Param[3].vData^, 1); + Move (Session.io.ScreenInfo[Param[1].B].A, Param[4].vData^, 1); + End; + 530 : If Param[1].B < FileSize(Session.PromptFile) Then Begin + Seek (Session.PromptFile, Param[1].B); + Write (Session.PromptFile, Param[2].S); + End; + 531 : Begin + TempChar := Session.io.MorePrompt; + Store (TempChar, 1); + End; + 532 : Session.io.PauseScreen; + 533 : If Param[1].B <= MaxPromptInfo Then Session.io.PromptInfo[Param[1].B] := Param[2].S; + 534 : Session.io.BufFlush; + 535 : Begin + TempStr := Session.io.StrMci(Param[1].S); + Store (TempStr, 256); + End; + 536 : Begin + TempChar := #0; + + If (Param[1].B < 81) and (Param[2].B < 26) Then + TempChar := Screen.Buffer[Param[2].B][Param[1].B].UnicodeChar; + + Store (TempChar, 1); + End; + 537 : Begin + TempByte := 0; + + If (Param[1].B < 81) and (Param[2].B < 26) Then + TempByte := Screen.Buffer[Param[2].B][Param[1].B].Attributes; + + Store (TempByte, 1); + End; + End; +End; + +Procedure TInterpEngine.SkipBlock; +begin + NextChar; + NextWord; + MoveToPos (CurFilePos + W); +end; + +Procedure TInterpEngine.DefineProcedure; +Var + Count : Word; + VarChar : Char; + Params : Word; + NumVars : Word; +Begin + NextWord; { procedure var id } + + If FindVariable(W) > 0 Then Begin /// ???????????????????? + Error (mpxMultiInit, ''); + Exit; + End; + + Inc (CurVarNum); + New (VarData[CurVarNum]); + + With VarData[CurVarNum]^ Do Begin + VarID := W; + vType := iNone; + NumParams := 0; + ProcPos := 0; + VarSize := 0; + Datasize := 0; + ArrPos := 0; + Kill := False; + Data := NIL; + End; + + NextChar; + Params := 0; + + While (ErrNum = 0) And (Not (Ch in [Char(opProcType), Char(opBlockOpen)])) Do Begin + VarChar := Ch; + NextWord; + NumVars := W; + For Count := 1 To NumVars Do Begin + Inc(Params); + VarData[CurVarNum]^.Params[Params] := VarChar; + NextWord; + VarData[CurVarNum]^.pID[Params] := W; + End; + NextChar; + End; + + If Ch = Char(opProcType) Then Begin + NextChar; + + VarData[CurVarNum]^.vType := cVarType(Ch); + VarData[CurVarNum]^.VarSize := xVarSize(VarData[CurVarNum]^.vType); + End Else + PrevChar; + + VarData[CurVarNum]^.NumParams := Params; + VarData[CurVarNum]^.ProcPos := CurFilePos; + + SkipBlock; +End; + +Procedure TInterpEngine.StatementForLoop; +Var + VarNum : Word; + VarArray : TArrayInfo; + LoopStart : Real; + LoopEnd : Real; + Count : Real; + CountTo : Boolean; + SavedPos : LongInt; +Begin + NextWord; + + VarNum := FindVariable(W); + + CheckArray (VarNum, VarArray); + + LoopStart := EvaluateNumber; + + NextChar; + + CountTo := Ch = Char(opTo); + LoopEnd := EvaluateNumber; + Count := LoopStart; + SavedPos := CurFilePos; + + If (CountTo And (LoopStart > LoopEnd)) Or ((Not CountTo) And (LoopStart < LoopEnd)) Then + SkipBlock + Else + If CountTo Then + While (Count <= LoopEnd) And Not Done Do Begin + SetNumber(VarNum, Count, VarArray); + MoveToPos(SavedPos); + If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Break; + Count := GetNumber(VarNum, VarArray) + 1; + End + Else + While (Count >= LoopEnd) And Not Done Do Begin + SetNumber(VarNum, Count, VarArray); + MoveToPos(SavedPos); + If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Break; + Count := GetNumber(VarNum, VarArray) - 1; + End; +End; + +Procedure TInterpEngine.StatementWhileDo; +Var + IsTrue : Boolean; + StartPos : LongInt; +begin + StartPos := CurFilePos; + IsTrue := True; + + While (ErrNum = 0) And IsTrue And Not Done Do Begin + IsTrue := EvaluateBoolean; + + If IsTrue Then Begin + If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Begin + MoveToPos (StartPos); + EvaluateBoolean; + SkipBlock; + Break; + End Else + MoveToPos (StartPos); + End Else + SkipBlock; + End; +End; + +Procedure TInterpEngine.StatementRepeatUntil; +Var + StartPos: LongInt; +Begin + StartPos := CurFilePos; + + Repeat + MoveToPos (StartPos); + If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Begin + EvaluateBoolean; + Break; + End; + Until (ErrNum <> 0) or (EvaluateBoolean) or Done; +End; + +Function TInterpEngine.StatementCase : Byte; +Var + StartPos : LongInt; + EndPos : LongInt; + TempStr : String; + TempBol : Boolean; + TempNum : Real; + Found : Boolean; + VarType : TIdentTypes; + Numbers : Array[1..mplMaxCaseNums] of Record + Num : Real; + Range : Boolean; + End; + NumberPos : Word; + Count : Word; + Str : String; +Begin + NextWord; // statement size + + Result := 0; + StartPos := CurFilePos; + EndPos := W; + Found := False; + NumberPos := 0; + + NextChar; + + VarType := TIdentTypes(Byte(Ch)); + + Case VarType of + iChar, + iString : TempStr := EvaluateString; + iBool : TempBol := EvaluateBoolean; + Else + TempNum := EvaluateNumber; + End; + + Repeat + Case VarType of + iChar, + iString : Repeat + Str := EvaluateString; + Found := Found or (TempStr = Str); + + NextChar; + + If Ch <> Char(opParamSep) Then Begin + PrevChar; + Break; + End; + Until ErrNum <> 0; + iBool : Found := EvaluateBoolean = TempBol; + Else + Repeat + Inc (NumberPos); + Numbers[NumberPos].Num := EvaluateNumber; + + NextChar; + + If Ch = Char(opParamSep) Then + Numbers[NumberPos].Range := False + Else + If Ch = Char(opNumRange) Then + Numbers[NumberPos].Range := True + Else Begin + Numbers[NumberPos].Range := False; + PrevChar; + Break; + End; + Until ErrNum <> 0; + + Count := 1; + + Repeat + If Numbers[Count].Range Then + Found := (TempNum >= Numbers[Count].Num) and (TempNum <= Numbers[Count + 1].Num) + Else + Found := TempNum = Numbers[Count].Num; + + Inc (Count); + Until Found or (Count > NumberPos); + End; + + If Found Then Begin + Result := ExecuteBlock (CurVarNum, CurRecNum); + MoveToPos (StartPos + EndPos); + Exit; + End Else + SkipBlock; + + NextChar; + + If Ch = Char(opElse) Then Begin + // we probably want to skip the open block here in compiler + Result := ExecuteBlock(CurVarNum, CurRecNum); + Break; + End Else + If Ch = Char(opBlockClose) Then + Break + Else + PrevChar; + + Until (ErrNum > 0) or Done; +End; + +Function TInterpEngine.StatementIfThenElse : Byte; +Var + Ok : Boolean; +Begin + Result := 0; + + Ok := EvaluateBoolean; + + //tbbscore(owner).systemlog('if statement'); + //if ok then tbbscore(owner).systemlog('is true') else tbbscore(owner).systemlog('is false'); + + If Ok Then + Result := ExecuteBlock(CurVarNum, CurRecNum) + Else + SkipBlock; + + NextChar; + + If Ch = Char(opElse) Then Begin + If Not Ok Then + Result := ExecuteBlock(CurVarNum, CurRecNum) + Else + SkipBlock; + End Else + PrevChar; +End; + +Procedure TInterpEngine.DefineRecord; +Var + Count : LongInt; + RecSize : LongInt; +Begin + NextWord; + + Inc (CurRecNum); + New (RecData[CurRecNum]); + + RecData[CurRecNum]^.RecStart := CurVarNum + 1; + RecData[CurRecNum]^.NumFields := W; + +// DefineVariable; // base record variable + + RecSize := 0; + + For Count := 1 to RecData[CurRecNum]^.NumFields Do Begin + NextChar; + + Inc (RecSize, DefineVariable); + End; + + // now we need to build something to create a record block of data + // and to dispose it based on the variables + // this method will not work for records in records or arrays of records + // and really should be re-done. the problem is, the evaluators will + // take a lot of changes to suport iRecord correctly. +End; + +Function TInterpEngine.ExecuteBlock (StartVar, StartRec: Word) : Byte; +Var + Count : Word; + BlockStart : LongInt; + BlockSize : Word; +Begin + Result := 0; + + NextChar; // block begin character... can we ignore it? at least for case_else + NextWord; // or just have case else ignore the begin at the compiler level + // but still output the begin + + BlockStart := CurFilePos; + BlockSize := W; + + Repeat + NextChar; + + Case TTokenOpsRec(Byte(Ch)) of +{0} opBlockOpen : Begin + PrevChar; + Self.ExecuteBlock(CurVarNum, CurRecNum); + End; +{1} opBlockClose : Break; +{2} opVarDeclare : DefineVariable; +{12} opSetVar : Begin + NextWord; + SetVariable(FindVariable(W)); + End; +{18} opProcDef : DefineProcedure; +{19} opProcExec : ExecuteProcedure(NIL); +{21} opFor : StatementForLoop; +{34} opIf : Begin + Result := StatementIfThenElse; + If Result > 0 Then Begin + MoveToPos(BlockStart + BlockSize); + Break; + End; + End; +{36} opWhile : StatementWhileDo; +{39} opRepeat : StatementRepeatUntil; +{47} opGoto : Begin + NextWord; + MoveToPos(W); + End; +{49} opHalt : Done := True; +{50} opCase : Begin + Result := StatementCase; + If Result > 0 Then Begin + MoveToPos(BlockStart + BlockSize); + Break; + End; + End; +{52} opTypeRec : DefineRecord; +{53} opBreak : Begin + MoveToPos (BlockStart + BlockSize); + Result := 1; + Break; + End; +{54} opContinue : Begin + MoveToPos (BlockStart + BlockSize); + Result := 2; + Break; + End; +{55} opUses : Begin + Repeat + NextWord; + InitProcedures (Owner, Self, VarData, CurVarNum, CurVarID, W); + NextChar; + If Ch <> Char(opParamSep) Then Begin + PrevChar; + Break; + End; + Until ErrNum <> 0; + End; +{56} opExit : Begin + Done := True; + ExitProc := True; + End; + Else + Error (mpxUnknownOp, strI2S(Ord(Ch))); + End; + Until (ErrNum <> 0) or Done or DataFile^.EOF; + + {$IFDEF LOGGING} + Session.SystemLog('MPE: Kill Block Vars'); + {$ENDIF} + + For Count := CurVarNum DownTo StartVar + 1 Do Begin + If (VarData[Count]^.Kill) And (VarData[Count]^.Data <> NIL) Then begin + FreeMem(VarData[Count]^.Data, VarData[Count]^.DataSize); + end; + + Dispose (VarData[Count]); + End; + + {$IFDEF LOGGING} + Session.SystemLog('MPE: Kill Block Done'); + {$ENDIF} + + For Count := CurRecNum DownTo StartRec + 1 Do + Dispose(RecData[Count]); + // dispose record data block? or just calc it whenever there is an + // assignment or filewrite, etc? + + CurVarNum := StartVar; + CurRecNum := StartRec; +End; + +Function TInterpEngine.Execute (FN: String) : Byte; +// 0 = not found 1 = ok 2 = goto new menu +Var + VerStr : String; + Res : LongInt; +Begin + Result := 0; + CurVarNum := 0; + CurVarID := 0; + CurRecNum := 0; + ReloadMenu := False; + Done := False; + ExitProc := False; + SavedMCI := Session.io.AllowMCI; + SavedGroup := Session.User.IgnoreGroup; + SavedArrow := Session.io.AllowArrow; + DataFile := New(PCharFile, Init(mplExecuteBuffer)); + + Session.io.AllowArrow := True; + + If strWordCount(FN, ' ') > 1 Then Begin + ParamsStr := Copy(FN, strWordPos(2, FN, ' '), Length(FN)); + FN := strWordGet(1, FN, ' '); + End Else + ParamsStr := ''; + + If Pos('.', FN) = 0 Then FN := FN + mplExtExecute; + + If Pos(PathChar, FN) = 0 Then + FN := Config.ScriptPath + FN; + + MPEName := FN; + + If Not DataFile^.Open(FN) Then Begin + Dispose(DataFile, Done); + Exit; + End; + + Result := 1; + + If DataFile^.FileSize < mplVerLength Then Begin + DataFile^.Close; + Error (mpxInvalidFile, FN); + Dispose (DataFile, Done); + Exit; + End; + + DataFile^.BlockRead (VerStr[1], mplVerLength, Res); + VerStr[0] := Chr(mplVerLength); + + If VerStr <> mplVersion Then Begin + DataFile^.Close; + Error (mpxVerMismatch, VerStr); + Dispose (DataFile, Done); + Exit; + End; + + InitProcedures (Owner, Self, VarData, CurVarNum, CurVarID, 0); + ExecuteBlock (CurVarNum, CurRecNum); + + DataFile^.Close; + + Dispose(DataFile, Done); + + Session.io.AllowMCI := SavedMCI; + Session.User.IgnoreGroup := SavedGroup; + Session.io.AllowArrow := SavedArrow; + + Result := Ord(ReloadMenu) + 1; +End; + +Function ExecuteMPL (Owner: Pointer; Str: String) : Byte; +Var + Script : TInterpEngine; +Begin + Script := TInterpEngine.Create(Owner); + Result := Script.Execute(Str); + + If Script.ErrNum > 0 Then + Session.io.OutFullLn ('|CR|12MPX ERROR: ' + Script.GetErrorMsg); + + Script.Free; +End; + +End. diff --git a/mystic/mpl_fileio.pas b/mystic/mpl_fileio.pas new file mode 100644 index 0000000..438856e --- /dev/null +++ b/mystic/mpl_fileio.pas @@ -0,0 +1,156 @@ +{$I M_OPS.PAS} + +Unit MPL_FileIO; + +// all file io units should be compiled into one source file... +// also, make this ONLY allocate the size of the file if the file size is +// less than the buffer. + +Interface + +Const + MaxBufferSize = 64 * 1024; + +Type + PCharRec = ^TCharRec; + TCharRec = Array[0..MaxBufferSize - 1] of Char; + + PCharFile = ^TCharFile; + TCharFile = Object + BufSize : LongInt; + Buffer : PCharRec; + BufRead : LongInt; + BufStart : LongInt; + BufEnd : LongInt; + BufPos : LongInt; + InFile : File; + BufEOF : Boolean; + + Constructor Init (BufferSize: LongInt); + Destructor Done; + + Function Open (FN : String) : Boolean; + Procedure Close; + Function Read : Char; + Procedure BlockRead (Var Buf; Size: LongInt; Var Count: LongInt); + Procedure Seek (FP : LongInt); + Function FilePos : LongInt; + Function FileSize : LongInt; + Function EOF : Boolean; + Procedure FillBuffer; + End; + +Implementation + +Function TCharFile.FilePos : LongInt; +Begin + FilePos := BufStart + BufPos; +End; + +Procedure TCharFile.FillBuffer; +Var + Start : LongInt; +Begin + Start := System.FilePos(InFile); + + System.BlockRead (InFile, Buffer^[0], BufSize, BufRead); + + BufStart := Start; + BufEnd := Start + BufRead; + BufPos := 0; + BufEOF := System.EOF(InFile); +End; + +Constructor TCharFile.Init (BufferSize: LongInt); +Begin + BufSize := BufferSize; + BufStart := 0; + BufEnd := 0; + BufPos := 0; + BufEOF := False; + BufRead := 0; + Buffer := NIL; +End; + +Destructor TCharFile.Done; +Begin + If Assigned(Buffer) Then Begin + FreeMem (Buffer, BufSize); + Buffer := NIL; + End; +End; + +Function TCharFile.Open (FN : String) : Boolean; +Begin + Open := False; + FileMode := 66; + + Assign (InFile, FN); + Reset (InFile, 1); + + If IoResult <> 0 Then Exit; + + If BufSize > System.FileSize(InFile) Then + BufSize := System.FileSize(InFile); + + If Assigned(Buffer) Then Done; + + GetMem (Buffer, BufSize); + + FillBuffer; + + Open := True; +End; + +Procedure TCharFile.Close; +Begin + System.Close (InFile); + Done; +End; + +Function TCharFile.Read : Char; +Begin + If BufPos >= BufSize Then FillBuffer; + + Read := Buffer^[BufPos]; + + Inc (BufPos); +End; + +Procedure TCharFile.BlockRead (Var Buf; Size: LongInt; Var Count: LongInt); +Begin + If BufPos + Size >= BufRead Then Begin + If Size > BufSize Then Size := BufSize; + System.Seek(InFile, BufStart + BufPos); + FillBuffer; + If BufRead < Size Then Size := BufRead; + End; + + Move (Buffer^[BufPos], Buf, Size); + + Inc (BufPos, Size); + + Count := Size; +End; + +Procedure TCharFile.Seek (FP : LongInt); +Begin + If (FP >= BufStart) and (FP < BufEnd) Then + BufPos := (BufEnd - (BufEnd - FP)) - BufStart + Else Begin + System.Seek(InFile, FP); + FillBuffer; + End; +End; + +Function TCharFile.EOF : Boolean; +Begin + EOF := (BufStart + BufPos >= BufEnd) and BufEOF; +End; + +Function TCharFile.FileSize : LongInt; +Begin + FileSize := System.FileSize(InFile); +End; + +End. diff --git a/mystic/mpl_types.pas b/mystic/mpl_types.pas new file mode 100644 index 0000000..b0a641f --- /dev/null +++ b/mystic/mpl_types.pas @@ -0,0 +1,294 @@ +Type + TIdentTypes = ( + iNone, + iString, + iChar, + iByte, + iShort, + iWord, + iInteger, + iLongInt, + iReal, + iBool, + iFile, + iRecord + ); + + TTokenOpsRec = ( + opBlockOpen, // 1 + opBlockClose, // 2 + opVarDeclare, // 3 + opStr, // 4 + opChar, // 5 + opByte, // 6 + opShort, // 7 + opWord, // 8 + opInt, // 9 + opLong, // 10 + opReal, // 11 + opBool, // 12 + opSetVar, // 13 + opLeftParan, // 14 + opRightParan, // 15 + opVariable, // 16 + opOpenString, // 17 + opCloseString, // 18 + opProcDef, // 19 + opProcExec, // 20 + opParamSep, // 21 + opFor, // 22 + opTo, // 23 + opDownTo, // 24 + opTrue, // 25 + opFalse, // 26 + opEqual, // 27 + opNotEqual, // 28 + opGreater, // 29 + opLess, // 30 + opEqGreat, // 31 + opEqLess, // 32 + opStrAdd, // 33 + opProcType, // 34 + opIf, // 35 + opElse, // 36 + opWhile, // 37 + opOpenNum, // 38 + opCloseNum, // 39 + opRepeat, // 40 + opNot, // 41 + opAnd, // 42 + opOr, // 43 + opStrArray, // 44 + opArrDef, // 45 + opStrSize, // 46 + opVarNormal, // 47 + opGoto, // 48 + opHalt, // 49 + opCase, // 50 + opNumRange, // 51 + opTypeRec, // 52 + opBreak, // 53 + opContinue, // 54 + opUses, // 55 + opExit, // 56 + opNone // 57 + ); + +Const + mplVer = '110'; + mplVersion = '[MPX ' + mplVer +']' + #26; + mplVerLength = 10; + mplExtSource = '.mps'; + mplExtExecute = '.mpx'; + mplMaxInclude = 10; + mplMaxFiles = 20; + mplMaxIdentLen = 20; + mplMaxVars = 2500; + mplMaxGotos = 100; + mplMaxCaseNums = 20; + mplMaxVarDeclare = 20; + mplMaxArrayDem = 3; //cannot be changed yet + mplMaxProcParams = 8; + mplMaxRecords = 20; + mplMaxRecFields = 40; + mplMaxDataSize = 65535; + mplMaxConsts = 100; + +Const + chNumber = ['0'..'9','.']; + chIdent1 = ['a'..'z','A'..'Z','_']; + chIdent2 = ['a'..'z','A'..'Z','0'..'9','_']; + chDigit = ['0'..'9']; + chHexDigit = ['0'..'9','A'..'F','a'..'f']; + +{$IFNDEF MPLPARSER} + mpxEndOfFile = 1; + mpxInvalidFile = 2; + mpxVerMismatch = 3; + mpxUnknownOp = 4; + mpxMultiInit = 5; + mpxDivisionByZero = 6; + mpxMathematical = 7; +{$ELSE} + mpsEndOfFile = 1; + mpsFileNotfound = 2; + mpsFileRecurse = 3; + mpsOutputFile = 4; + mpsExpected = 5; + mpsUnknownIdent = 6; + mpsInStatement = 7; + mpsIdentTooLong = 8; + mpsExpIdentifier = 9; + mpsTooManyVars = 10; + mpsDupIdent = 11; + mpsOverMaxDec = 12; + mpsTypeMismatch = 13; + mpsSyntaxError = 14; + mpsStringNotClosed = 15; + mpsStringTooLong = 16; + mpsTooManyParams = 17; + mpsBadProcRef = 18; + mpsNumExpected = 19; + mpsToOrDowntoExp = 20; + mpsExpOperator = 21; + mpsOverArrayDim = 22; + mpsNoInitArray = 23; + mpsTooManyGotos = 24; + mpsDupLabel = 25; + mpsLabelNotFound = 26; + mpsFileParamVar = 27; + mpsBadFunction = 28; + mpsOperation = 29; + mpsOverMaxCase = 30; + mpsTooManyFields = 31; + mpsDataTooBig = 32; + mpsMaxConsts = 33; +{$ENDIF} + +// ========================================================================== + +{$IFDEF MPLPARSER} +Type + TTokenWordRec = (wBlockOpen, wBlockClose, wVarDeclare, wVarSep, + wSetVar, wLeftParan, wRightParan, wOpenString, + wCloseString, wStrAdd, wCharPrefix, wProcDef, + wOpenParam, wCloseParam, wParamVar, wParamSpec, + wFuncSpec, wParamSep, wFor, wTo, + wDownTo, wDo, wTrue, wFalse, + wOpEqual, wOpNotEqual, wOpGreater, wOpLess, + wOpEqGreat, wOpEqLess, wIf, wThen, + wElse, wWhile, wRepeat, wUntil, + wNot, wAnd, wOr, wOpenArray, + wCloseArray, wArrSep, wVarDef, wOpenStrSize, + wCloseStrSize, wGoto, wLabel, wHalt, + wVarSep2, wFuncDef, wArray, wCaseStart, + wCaseOf, wNumRange, wType, wConst, + wBreak, wContinue, wUses, wExit, + wHexPrefix, wExpAnd, wExpOr, wExpXor, + wExpShl, wExpShr); +{$ENDIF} + + +Const + {$IFDEF MPLPARSER} + tkv : Array[TIdentTypes] of String[mplMaxIdentLen] = ( + 'none', 'string', 'char', 'byte', + 'shortint', 'word', 'integer', 'longint', + 'real', 'boolean', 'file', 'record'); + +Type + TTokenWordType = Array[TTokenWordRec] of String[mplMaxIdentLen]; + +Const + wTokensPascal : TTokenWordType = ( + 'begin', 'end', 'var', ',', + ':=', '(', ')', '''', + '''', '+', '#', 'procedure', + '(', ')', '+', ';', + ':', ',', 'for', 'to', + 'downto', 'do', 'true', 'false', + '=', '<>', '>', '<', + '>=', '<=', 'if', 'then', + 'else', 'while', 'repeat', 'until', + 'not', 'and', 'or', '[', + ']', ',', '=', '[', + ']', 'goto', ':', 'halt', + ':', 'function', 'array', 'case', + 'of', '..', 'type', 'const', + 'break', 'continue', 'uses', 'exit', + '$', 'and', 'or', 'xor', 'shl', 'shr' + ); + + wTokensIPLC : TTokenWordType = ( + '{', '}', '@', ',', + '=', '(', ')', '"', + '"', '+', '#', 'proc', + '(', ')', '+', ';', + ':', ',', 'for', 'to', + 'downto', 'do', 'true', 'false', + '==', '<>', '>', '<', + '>=', '<=', 'if', 'then', + 'else', 'while', 'repeat', 'until', + '!', '&&', '||', '(', + ')', ',', '=', '[', + ']', 'goto', ':', 'halt', + ':', 'func', 'array', 'switch', + 'of', '..', 'type', 'const', + 'break', 'continue', 'uses', 'exit', + '$', '&', '|', 'xor', '<<', '>>' + ); + + {$ENDIF} + + vNums : Set of TIdentTypes = [iByte, iShort, iWord, iInteger, iLongInt, iReal]; + vStrings : Set of TIdentTypes = [iChar, iString]; + +Type + {$IFNDEF MPLPARSER} + PStack = ^TStack; + TStack = Array[1..mplMaxDataSize] of Byte; + TArrayInfo = Array[1..mplMaxArrayDem] of Word; + +(* +// MEMORY SAVING... could be 28 bytes per var?!?! +// could at least make a procrec that tvarrec links to via a pointer. would +// save us about 25 bytes per var... which is about half the memory. we +// could also remove IsProc var in TVar because we could just check to see +// if Proc : Pointer is assigned... + PProcInfoRec = ^TProcInfoRec; + TProcInfoRec = Record + Params : Array[1..mplMaxProcParams] of Char; + ParamID : Array[1..mplMaxProcParams] of Word; + NumParams : Byte; + Position : LongInt; + End; +*) + + PVarRec = ^TVarRec; + TVarRec = Record + VarID : Word; + vType : TIdentTypes; + Params : Array[1..mplMaxProcParams] of Char; + NumParams : Byte; + pID : Array[1..mplMaxProcParams] of Word; + ProcPos : LongInt; + DataSize : Word; + VarSize : Word; + Data : PStack; + Kill : Boolean; + ArrPos : Byte; + ArrDim : TArrayInfo; + End; + + PRecordRec = ^TRecordRec; + TRecordRec = Record +// RecID : Word; needed when Record variable type is added + RecStart : Word; + NumFields : Word; + End; + + VarDataRec = Array[1..mplMaxVars] of PVarRec; + RecDataRec = Array[1..mplMaxRecords] of PRecordRec; + {$ELSE} + PVarRec = ^TVarRec; + TVarRec = Record + VarID : Word; + Ident : String[mplMaxIdentLen]; + VType : TIdentTypes; + Params : Array[1..mplMaxProcParams] of Char; + NumParams : Byte; + InProc : Boolean; + Proc : Boolean; + ArrPos : Byte; + End; + + PGotoRec = ^TGotoRec; + TGotoRec = Record + Ident : String[mplMaxIdentLen]; + xPos : LongInt; + Stat : Byte; + End; + + VarDataRec = Array[1..mplMaxVars] of PVarRec; +{$ENDIF} + diff --git a/mystic/mplc.pas b/mystic/mplc.pas new file mode 100644 index 0000000..d96be6b --- /dev/null +++ b/mystic/mplc.pas @@ -0,0 +1,93 @@ +// ==================================================================== +// Mystic BBS Software Copyright 1997-2012 By James Coyle +// ==================================================================== +// +// This file is part of Mystic BBS. +// +// Mystic BBS is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Mystic BBS is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Mystic BBS. If not, see . +// +// ==================================================================== + +{$I m_OPS.PAS} + +Program MPLC; + +Uses + m_Output, + m_Strings, + Dos, + MPL_Compile; + +Var + SavedX : Byte; + Console : TOutput; + WasError : Boolean; + +Procedure Status (Info: TParserUpdateInfo); +Begin + Case Info.Mode of + StatusStart : Begin + Console.WriteStr('Compiling ' + Info.FileName + ' ... '); + SavedX := Console.CursorX; + End; + StatusUpdate : Begin + Console.CursorXY (SavedX, Console.CursorY); + Console.WriteStr (strPadL(strI2S(Info.Percent), 3, ' ') + '%'); + End; + StatusDone : If Info.ErrorType = 0 Then Begin + Console.CursorXY (SavedX, Console.CursorY); + Console.WriteLine ('Success!'); + End Else Begin + WasError := True; + Console.WriteLine(#13#10#13#10'Error in ' + Info.FileName + ' (Line:' + strI2S(Info.ErrorLine) + ', Col:' + strI2S(Info.ErrorCol) + '): ' + Info.ErrorText); + End; + End; +End; + +Var + Parser : TParserEngine; + Dir : SearchRec; +Begin + WasError := False; + Console := TOutput.Create(True); + + Console.WriteLine (#13#10'Mystic BBS Programming Language Compiler Version ' + mysVersion); + Console.WriteLine ('Copyright (C) 1997-2011 By James Coyle. All Rights Reserved.'#13#10); + + If ParamCount = 0 Then + WriteLn ('MPLC [filename] or MPLC -ALL') + Else Begin + If Pos('-ALL', strUpper(ParamStr(1))) > 0 Then Begin + FindFirst ('*.mps', AnyFile - Directory - VolumeID, Dir); + While DosError = 0 Do Begin + Parser := TParserEngine.Create(Status); + If Not Parser.Compile(Dir.Name) Then Begin + Parser.Free; + Break; + End; + FindNext(Dir); + Parser.Free; + End; + FindClose(Dir); + End Else Begin + Parser := TParserEngine.Create(Status); + Parser.Compile(ParamStr(1)); + Parser.Free; + End; + End; + + Console.Free; + + If WasError Then Halt(1); +End. diff --git a/mystic/mystpack.pas b/mystic/mystpack.pas new file mode 100644 index 0000000..de79d68 --- /dev/null +++ b/mystic/mystpack.pas @@ -0,0 +1,555 @@ +// This file is part of Mystic BBS. +// +// Mystic BBS is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Mystic BBS is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Mystic BBS. If not, see . + +Program MP; + +{ when DELETEing a message, the pointers are one less than they should be } +{ should be fixed, but may cause other problems. commented out the last } +{ read updating in the msgkill part of the program } + +{ also when a user is reading a base, it could cause MP to crash with an } +{ RTE 005: access violation error } + +{$I M_OPS.PAS} + +Uses + m_FileIO, + m_Strings, + m_DateTime, + CRT, + DOS; + +{$I RECORDS.PAS} + +Const + PackVer = '1.2'; + Jam_Deleted = $80000000; + JamSubBufSize = 4096; + +Type + JamSubBuffer = Array[1..JamSubBufSize] of Char; + + JamHdrType = Record + Signature : Array[1..4] of Char; + Created : LongInt; + ModCounter : LongInt; + ActiveMsgs : LongInt; + PwdCRC : LongInt; + BaseMsgNum : LongInt; + HighWaterMark : Longint; + Extra : Array[1..996] of Char; + End; + + JamMsgHdrType = Record + Signature : Array[1..4] of Char; + Rev : Word; + Resvd : Word; + SubFieldLen : LongInt; + TimesRead : LongInt; + MsgIdCrc : LongInt; + ReplyCrc : LongInt; + ReplyTo : LongInt; + ReplyFirst : LongInt; + ReplyNext : LongInt; + DateWritten : LongInt; + DateRcvd : LongInt; + DateArrived : LongInt; + MsgNumber : LongInt; + Attr1 : LongInt; + Attr2 : LongInt; + TextOfs : LongInt; + TextLen : LongInt; + PwdCrc : LongInt; + Cost : LongInt; + End; + + JamIdxType = Record + MsgToCrc : LongInt; + HdrLoc : LongInt; + End; + + JamLastType = Record + NameCrc : LongInt; + UserNum : LongInt; + LastRead : LongInt; + HighRead : LongInt; + End; + + SubFieldType = Record + LoId : Word; + HiId : Word; + DataLen : LongInt; + Data : Array[1..1000] of Char; + End; + + TxtType = Array[1..65000] of Char; + + JamType = Record + Hdr : JamHdrType; + MsgHdr : JamMsgHdrType; + HdrFile : File; + Idx : JamIdxType; + IdxFile : File of JamIdxType; + Last : JamLastType; + LastFile : File of JamLastType; + TxtFile : File; + SubField : SubFieldType; + End; + +Const + SpinStr : String[8] = ('\|/-\|/-'); + SpinPos : Byte = 1; + SkipFirst : Boolean = False; + PackMsgs : Boolean = False; + +Var + ConfigFile : File of RecConfig; + MBaseFile : File of MBaseRec; + Config : RecConfig; + MBase : MBaseRec; + +Const + DATEC1970 = 2440588; + DATED0 = 1461; + DATED1 = 146097; + DATED2 = 1721119; + +Procedure UnixToDT(SecsPast: LongInt; Var Dt: DateTime); +Var + DateNum : LongInt; + N1 : Word; +Begin + Datenum := (SecsPast Div 86400) + DATEc1970; + + DateJ2G(DateNum, SmallInt(N1), SmallInt(DT.Month), SmallInt(DT.day)); + DT.Year := N1; + + SecsPast := SecsPast Mod 86400; + DT.Hour := SecsPast Div 3600; + SecsPast := SecsPast Mod 3600; + DT.Min := SecsPast Div 60; + DT.Sec := SecsPast Mod 60; +End; + +Procedure PWrite (Str : String); +Var + A : Byte; + Code : String[2]; +Begin + A := 1; + While A <= Length(Str) Do Begin + If (Str[A] = '|') and (A < Length(Str) - 1) Then Begin + Code := Copy(Str, A + 1, 2); + + If (Code = '00') or (strS2I(Code) > 0) Then Begin + If strS2I(Code) < 16 Then + TextColor(strS2I(Code)) + Else + TextBackground(strS2I(Code) - 16); + End Else + Write(Str[A] + Code); + + Inc (A, 2); + End Else + Write(Str[A]); + + Inc(A); + End; +End; + +Procedure PWriteLN (Str : String); +Begin + PWrite (Str + #13#10); +End; + +Procedure UpdateSpin; +Begin + Write (#8 + SpinStr[SpinPos]); + Inc (SpinPos); + + If SpinPos > 8 Then SpinPos := 1; +End; + +Procedure PackJAMBase (Var TotalKilled : LongInt; Var SavedBytes : LongInt); +Var + BasePath : String; + OldHdrFile : File; + OldTxtFile : File; + OldIdxFile : File of JamIdxType; + NewHdrFile : File; + NewTxtFile : File; + NewIdxFile : File of JamIdxType; + TmpHdrFile : File; + LastFile : File of JamLastType; + Last : JamLastType; + SigHdr : JamHdrType; + MsgHdr : JamMsgHdrType; + TmpSigHdr : JamHdrType; + TmpMsgHdr : JamMsgHdrType; + MsgIdx : JamIdxType; + TxtBuf : ^TxtType; + SubField : SubFieldType; + Count : LongInt; + Killed : Boolean; + KillOffset : LongInt; + LimitKill : Boolean; + TotalMsgs : LongInt; + MsgDateTime : DateTime; + Temp : LongInt; + HaveHdr : Boolean; +Begin + PWrite ('|07Processing |08-> |07' + strPadR(MBase.Name, 35, ' ') + '|08 -> |07'); + + BasePath := MBase.Path + MBase.FileName; + + Assign (OldHdrFile, BasePath + '.jhr'); + Assign (OldTxtFile, BasePath + '.jdt'); + Assign (OldIdxFile, BasePath + '.jdx'); + + {$I-} Reset (OldHdrFile, 1); {$I+} + If IOResult <> 0 Then Exit; + + {$I-} Reset (OldTxtFile, 1); {$I+} + If IOResult <> 0 Then Begin + Close (OldHdrFile); + Exit; + End; + + {$I-} Reset (OldIdxFile); {$I+} + If IoResult <> 0 Then Begin + Close (OldHdrFile); + Close (OldTxtFile); + Exit; + End; + + Assign (LastFile, BasePath + '.jlr'); + {$I-} Reset (LastFile); {$I+} + If IoResult <> 0 Then ReWrite (LastFile); + Close (LastFile); + + Assign (NewHdrFile, BasePath + '._hr'); + ReWrite (NewHdrFile, 1); + Assign (NewTxtFile, BasePath + '._dt'); + ReWrite (NewTxtFile, 1); + Assign (NewIdxFile, BasePath + '._dx'); + ReWrite (NewIdxFile); + + BlockRead (OldHdrFile, SigHdr, SizeOf(SigHdr)); + + Inc (SigHdr.ModCounter); + + BlockWrite (NewHdrFile, SigHdr, SizeOf(SigHdr)); + + If SigHdr.ActiveMsgs > MBase.MaxMsgs Then + KillOffset := SigHdr.ActiveMsgs - MBase.MaxMsgs + Else + KillOffset := 0; + + TotalMsgs := 0; + TotalKilled := 0; + + New (TxtBuf); + + While Not Eof(OldIdxFile) Do Begin + UpdateSpin; + + Read (OldIdxFile, MsgIdx); + + If MsgIdx.HdrLoc = -1 Then Begin + Killed := True; + LimitKill := False; + HaveHdr := False; + End Else Begin + Seek (OldHdrFile, MsgIdx.HdrLoc); + + BlockRead (OldHdrFile, MsgHdr, SizeOf(MsgHdr)); + + LimitKill := False; + Killed := MsgHdr.Attr1 and Jam_Deleted <> 0; + HaveHdr := True; + + If MBase.MaxAge > 0 Then Begin + UnixToDT (MsgHdr.DateWritten, MsgDateTime); + PackTime (MsgDateTime, Temp); + + LimitKill := DaysAgo(Temp) > MBase.MaxAge; + Killed := Killed or LimitKill; + End; + + If MBase.MaxMsgs > 0 Then + If KillOffset > 0 Then Begin + Dec (KillOffset); + LimitKill := True; + Killed := True; + End; + + If SkipFirst and (MBase.NetType = 0) and (TotalMsgs = 0) and (MsgHdr.Attr1 and Jam_Deleted = 0) Then + Killed := False; + End; + + If Killed Then Begin + Inc (TotalKilled); + +(* + Reset (LastFile); + While Not Eof(LastFile) Do Begin + Read (LastFile, Last); + If (Last.LastRead > TotalMsgs) And Not LimitKill Then Begin + Dec (Last.LastRead); + Seek (LastFile, FilePos(LastFile) - 1); + Write (LastFile, Last); + End; + End; + Close (LastFile); +*) + If HaveHdr And (MsgHdr.ReplyFirst <> 0) Then Begin + Assign (TmpHdrFile, BasePath + '.jhr'); + Reset (TmpHdrFile, 1); + + BlockRead (TmpHdrFile, TmpSigHdr, SizeOf(TmpSigHdr)); + + While Not Eof(TmpHdrFile) Do Begin + BlockRead (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + + If TmpMsgHdr.ReplyTo = MsgHdr.MsgNumber Then Begin + TmpMsgHdr.ReplyTo := 0; + Seek (TmpHdrFile, FilePos(TmpHdrFile) - SizeOf(TmpMsgHdr)); + BlockWrite (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + End; + + Seek (TmpHdrFile, FilePos(TmpHdrFile) + TmpMsgHdr.SubFieldLen); + End; + Close (TmpHdrFile); + End; + + End Else Begin + Inc (TotalMsgs); + + If TotalKilled > 0 Then Begin + Reset (LastFile); + While Not Eof(LastFile) Do Begin + Read (LastFile, Last); + If Last.LastRead = MsgHdr.MsgNumber Then Begin + Last.LastRead := TotalMsgs; + Seek (LastFile, FilePos(LastFile) - 1); + Write (LastFile, Last); + End; + End; + Close (LastFile); + End; + + If (TotalKilled > 0) and (MsgHdr.ReplyFirst <> 0) Then Begin + Assign (TmpHdrFile, BasePath + '.jhr'); + Reset (TmpHdrFile, 1); + + BlockRead (TmpHdrFile, TmpSigHdr, SizeOf(TmpSigHdr)); + + While Not Eof(TmpHdrFile) Do Begin + BlockRead (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + + If TmpMsgHdr.ReplyTo = MsgHdr.MsgNumber Then Begin + TmpMsgHdr.ReplyTo := TotalMsgs; + Seek (TmpHdrFile, FilePos(TmpHdrFile) - SizeOf(TmpMsgHdr)); + BlockWrite (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + End; + + Seek (TmpHdrFile, FilePos(TmpHdrFile) + TmpMsgHdr.SubFieldLen); + End; + Close (TmpHdrFile); + End; + + If (TotalKilled > 0) and (MsgHdr.ReplyTo <> 0) Then Begin + Assign (TmpHdrFile, BasePath + '._hr'); + Reset (TmpHdrFile, 1); + + BlockRead (TmpHdrFile, TmpSigHdr, SizeOf(TmpSigHdr)); + + While Not Eof(TmpHdrFile) Do Begin + BlockRead (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + + If TmpMsgHdr.ReplyFirst = MsgHdr.MsgNumber Then Begin + TmpMsgHdr.ReplyFirst := TotalMsgs; + Seek (TmpHdrFile, FilePos(TmpHdrFile) - SizeOf(TmpMsgHdr)); + BlockWrite (TmpHdrFile, TmpMsgHdr, SizeOf(TmpMsgHdr)); + End; + + Seek (TmpHdrFile, FilePos(TmpHdrFile) + TmpMsgHdr.SubFieldLen); + End; + Close (TmpHdrFile); + End; + + MsgHdr.MsgNumber := TotalMsgs; + MsgIdx.HdrLoc := FilePos(NewHdrFile); + + (* write text from old file to new file *) + + If MsgHdr.TextLen > 65000 Then MsgHdr.TextLen := 65000; + // Why did I put this limitation here? Prob should be removed + + Seek (OldTxtFile, MsgHdr.TextOfs); + BlockRead (OldTxtFile, TxtBuf^, MsgHdr.TextLen); + + MsgHdr.TextOfs := FileSize(NewTxtFile); + + BlockWrite (NewTxtFile, TxtBuf^, MsgHdr.TextLen); + + (* write header from old to new file *) + + BlockWrite (NewHdrFile, MsgHdr, SizeOf(MsgHdr)); + + (* write subfield data if it exists *) + + If MsgHdr.SubFieldLen > 0 Then Begin + Count := 1; + + While (Count <= MsgHdr.SubFieldLen) Do Begin + BlockRead (OldHdrFile, SubField, 8); + BlockRead (OldHdrFile, SubField.Data, SubField.DataLen); + BlockWrite (NewHdrFile, SubField, 8); + BlockWrite (NewHdrFile, SubField.Data, SubField.DataLen); + + Inc (Count, 8 + SubField.DataLen); + End; + End; + + (* write new index to index file *) + + Write (NewIdxFile, MsgIdx); + End; + End; + + Dispose (TxtBuf); + + SigHdr.ActiveMsgs := TotalMsgs; + SigHdr.BaseMsgNum := 1; + + Reset (NewHdrFile, 1); + BlockWrite (NewHdrFile, SigHdr, SizeOf(SigHdr)); + + SavedBytes := (FileSize(OldHdrFile) - FileSize(NewHdrFile)) + + (FileSize(OldTxtFile) - FileSize(NewTxtFile)) + + ((FileSize(OldIdxFile) - FileSize(NewIdxFile)) * SizeOf(MsgIdx)); + + Close (OldHdrFile); + Close (OldTxtFile); + Close (OldIdxFile); + Close (NewHdrFile); + Close (NewTxtFile); + Close (NewIdxFile); + + Erase (OldHdrFile); + Erase (OldTxtFile); + Erase (OldIdxFile); + + ReName (NewHdrFile, BasePath + '.jhr'); + ReName (NewTxtFile, BasePath + '.jdt'); + ReName (NewIdxFile, BasePath + '.jdx'); + + If TotalKilled > 0 Then Begin + Reset (LastFile); + While Not Eof(LastFile) Do Begin + Read (LastFile, Last); + If Last.LastRead > TotalMsgs Then Last.LastRead := TotalMsgs; + If Last.HighRead > Last.LastRead Then Last.HighRead := Last.LastRead; + Seek (LastFile, FilePos(LastFile) - 1); + Write (LastFile, Last); + End; + Close (LastFile); + End; +End; + +Procedure ShowHelp; +Begin + WriteLn ('Invalid command line options'); + WriteLn; + WriteLn ('-PACK : Pack all jam message bases'); + WriteLn ('-SKIPFIRST : Skips the first message of each local message base'); + WriteLn; + PWriteLn ('|12NOTE: This program can sometimes crash if users are online.|07'); + Halt(1); +End; + +Var + TotalMsgs : LongInt; + TotalBytes : LongInt; + Msgs : LongInt; + Bytes : LongInt; + Count : Byte; + Str : String; +Begin + FileMode := 66; + + ClrScr; + PWriteLn ('|08-> |15MYSTPACK ' + PackVer + ' : JAM message base packer'); + PWriteLn ('|08-> |07Compatible with Mystic BBS software v' + mysVersion); + PWriteLn ('|08ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ|07'); + WriteLn; + + Window (1, 5, 80, 24); + + If ParamCount = 0 Then ShowHelp; + + For Count := 1 to ParamCount Do Begin + Str := strUpper(ParamStr(Count)); + + If Str = '-PACK' Then + PackMsgs := True + Else + If Str = '-SKIPFIRST' Then + SkipFirst := True + Else + ShowHelp; + End; + + Assign (ConfigFile, 'mystic.dat'); + {$I-} Reset (ConfigFile); {$I+} + If IoResult <> 0 Then Begin + WriteLn ('ERROR: Unable to read MYSTIC.DAT. Run from root Mystic directory'); + Halt(1); + End; + Read (ConfigFile, Config); + Close (ConfigFile); + + If Config.DataChanged <> mysDataChanged Then Begin + WriteLn('ERROR: Data files are not current and must be upgraded.'); + Halt(1); + End; + + Assign (MBaseFile, Config.DataPath + 'mbases.dat'); + {$I-} Reset(MBaseFile); {$I+} + If IoResult <> 0 Then Begin + WriteLn ('ERROR: Unable to read message area data'); + Halt(1); + End; + + While Not Eof(MBaseFile) Do Begin + Read (MBaseFile, MBase); + + If MBase.BaseType = 0 Then Begin + PackJAMBase(Msgs, Bytes); + WriteLn (#8 + 'Killed ', Msgs, '; ', Bytes, ' bytes'); + + Inc (TotalMsgs, Msgs); + Inc (TotalBytes, Bytes); + End; + End; + + Close (MBaseFile); + + WriteLn; + PWriteLn ('|08[|07-|08] |07Killed |15' + strI2S(TotalMsgs) + '|07 Msgs; Removed |15' + strI2S(TotalBytes) + '|07 bytes'); + + Window (1, 1, 80, 25); +End. diff --git a/mystic/records.pas b/mystic/records.pas new file mode 100644 index 0000000..351c3cb --- /dev/null +++ b/mystic/records.pas @@ -0,0 +1,697 @@ +{ + =========================================================================== + Mystic BBS Software Copyright (C) 1997-2012 By James Coyle + =========================================================================== + File | RECORDS.PAS + Desc | This file holds the data file records for all data files used + within Mystic BBS software. Mystic BBS is compiled with the + latest version of Free Pascal for all platforms. + =========================================================================== +} + +Const + mysSoftwareID = 'Mystic'; + mysCopyYear = '1997-2012'; + mysVersion = '1.10 A11'; + mysDataChanged = '1.10 A11'; + + {$IFDEF WIN32} + PathChar = '\'; + LineTerm = #13#10; + OSID = 'Windows'; + OSType = 0; + {$ENDIF} + + {$IFDEF LINUX} + PathChar = '/'; + LineTerm = #10; + OSID = 'Linux'; + OSType = 1; + {$ENDIF} + + {$IFDEF DARWIN} + PathChar = '/'; + LineTerm = #10; + OSID = 'OSX'; + OSType = 2; + {$ENDIF} + + mysMaxAcsSize = 30; // Max ACS string size + mysMaxPathSize = 80; + mysMaxMsgLines = 500; // Max message base lines + mysMaxInputHistory = 5; // Input history stack size + mysMaxFileDescLen = 50; + mysMaxBatchQueue = 50; + mysMaxVoteQuestion = 20; { Max number of voting questions } + mysMaxMenuNameLen = 20; + mysMaxMenuCmds = 75; { Maximum menu commands per menu } + mysMaxLanguageStr = 478; { Total # of strings in language file } + +Type + SmallWord = System.Word; + Integer = SmallInt; { force Integer to be a 2-byte signed } + Word = SmallWord; + + RecMessageText = Array[1..mysMaxMsgLines] of String[79]; + + AccessFlagType = Set of 1..25; { flags A to Z } + + RecEchoMailAddr = Record { FidoNet-style network address } + Zone, + Net, + Node, + Point : Word; + End; + + RecUserOptionalField = Record + Ask : Boolean; + Desc : String[12]; + iType : Byte; + iField : Byte; + iMax : Byte; + End; + + RecConfig = Record // MYSTIC.DAT + // INTERNALS + DataChanged : String[8]; // Version of last data change + SystemCalls : LongInt; // system caller number + UserIdxPos : LongInt; // permanent user # position + // SYSTEM PATHS + SystemPath : String[mysMaxPathSize]; + DataPath : String[mysMaxPathSize]; + LogsPath : String[mysMaxPathSize]; + MsgsPath : String[mysMaxPathSize]; + AttachPath : String[mysMaxPathSize]; + ScriptPath : String[mysMaxPathSize]; + QwkPath : String[mysMaxPathSize]; + SemaPath : String[mysMaxPathSize]; + TemplatePath : String[mysMaxPathSize]; + MenuPath : String[mysMaxPathsize]; + TextPath : String[mysMaxPathSize]; + WebPath : String[mysMaxPathSize]; + // GENERAL SETTINGS + BBSName : String[30]; + SysopName : String[30]; + SysopPW : String[15]; + SystemPW : String[15]; + FeedbackTo : String[30]; + Inactivity : Word; + LoginTime : Byte; + LoginAttempts : Byte; + PWAttempts : Byte; + PWChange : Word; + PWInquiry : Boolean; + DefStartMenu : String[20]; + DefFallMenu : String[20]; + DefThemeFile : String[20]; + DefTermMode : Byte; + DefScreenSize : Byte; + DefScreenCols : Byte; + UseMatrix : Boolean; + MatrixMenu : String[20]; + MatrixPW : String[15]; + MatrixAcs : String[mysMaxAcsSize]; + AcsSysop : String[mysMaxAcsSize]; + AcsInvisLogin : String[mysMaxAcsSize]; + AcsSeeInvis : String[mysMaxAcsSize]; + AcsMultiLogin : String[mysMaxAcsSize]; + SysopMacro : Array[1..4] of String[80]; // Sysop Macros + ChatStart : SmallInt; // Chat hour start + ChatEnd : SmallInt; // Chat hour end: mins since midnight + ChatFeedback : Boolean; // E-mail sysop if page isn't answered + ChatLogging : Boolean; // Record SysOp chat to CHAT.LOG? + UseStatusBar : Boolean; + StatusColor1 : Byte; + StatusColor2 : Byte; + StatusColor3 : Byte; + // NEW USER SETTINGS + AllowNewUsers : Boolean; + NewUserSec : SmallInt; + NewUserPW : String[15]; + NewUserEMail : Boolean; + StartMGroup : Word; + StartFGroup : Word; + UseUSAPhone : Boolean; + UserNameFormat : Byte; + UserDateType : Byte; // 1=MM/DD/YY 2=DD/MM/YY 3=YY/DD/MM 4=Ask + UserEditorType : Byte; // 0=Line 1=Full 2=Ask + UserHotKeys : Byte; // 0=no 1=yes 2=ask + UserFullChat : Byte; // 0=no 1=yes 2=ask + UserFileList : Byte; // 0=Normal 1=Lightbar 2=Ask + UserReadType : Byte; // 0=normal 1=ansi 2=ask + UserMailIndex : Byte; + UserReadIndex : Byte; + UserQuoteWin : Byte; + AskTheme : Boolean; + AskRealName : Boolean; + AskAlias : Boolean; + AskStreet : Boolean; + AskCityState : Boolean; + AskZipCode : Boolean; + AskHomePhone : Boolean; + AskDataPhone : Boolean; + AskBirthdate : Boolean; + AskGender : Boolean; + AskEmail : Boolean; + AskUserNote : Boolean; + AskScreenSize : Boolean; + AskScreenCols : Boolean; + OptionalField : Array[1..10] of RecUserOptionalField; + // MESSAGE BASE SETTINGS + MCompress : Boolean; + MColumns : Byte; + MShowHeader : Boolean; // re-show msg header after pause + MShowBases : Boolean; + MaxAutoSig : Byte; + qwkMaxBase : SmallInt; + qwkMaxPacket : SmallInt; + qwkArchive : String[4]; + qwkBBSID : String[8]; + qwkWelcome : String[mysMaxPathSize]; + qwkNews : String[mysMaxPathSize]; + qwkGoodbye : String[mysMaxPathSize]; + Origin : String[50]; // Default origin line + NetAddress : Array[1..30] of RecEchoMailAddr; // echomail addresses + NetDesc : Array[1..30] of String[20]; // echomail network description + NetCrash : Boolean; + NetHold : Boolean; + NetKillSent : Boolean; + ColorQuote : Byte; + ColorText : Byte; + ColorTear : Byte; + ColorOrigin : Byte; + ColorKludge : Byte; + AcsCrossPost : String[mysMaxAcsSize]; + AcsFileAttach : String[mysMaxAcsSize]; + AcsNodeLookup : String[mysMaxAcsSize]; + FSEditor : Boolean; + FSCommand : String[60]; + // FILE BASE SETTINGS + FCompress : Boolean; + FColumns : Byte; + FShowHeader : Boolean; + FShowBases : Boolean; + FDupeScan : Byte; // 0=no 1=yes 2=global + UploadBase : Word; // Default upload file base + ImportDIZ : Boolean; + FreeUL : LongInt; + FreeCDROM : LongInt; + MaxFileDesc : Byte; + FCommentLines : Byte; + FCommentLen : Byte; + TestUploads : Boolean; + TestPassLevel : Byte; + TestCmdLine : String[mysMaxPathSize]; + AcsValidate : String[mysMaxAcsSize]; + AcsSeeUnvalid : String[mysMaxAcsSize]; + AcsDLUnvalid : String[mysMaxAcsSize]; + AcsSeeFailed : String[mysMaxAcsSize]; + AcsDLFailed : String[mysMaxAcsSize]; + // INTERNET SERVER SETTINGS + inetDomain : String[25]; + inetIPBlocking : Boolean; + inetIPLogging : Boolean; + inetSMTPUse : Boolean; + inetSMTPPort : Word; + inetSMTPMax : Word; + inetSMTPDupes : Byte; + inetPOP3Use : Boolean; + inetPOP3Port : Word; + inetPOP3Max : Word; + inetPOP3Dupes : Byte; + inetTNUse : Boolean; + inetTNPort : Word; + inetTNMax : Byte; + inetTNDupes : Byte; + inetFTPUse : Boolean; + inetFTPPort : Word; + inetFTPMax : Word; + inetFTPDupes : Byte; + inetFTPPortMin : Word; + inetFTPPortMax : Word; + inetFTPAnon : Boolean; + inetFTPTimeout : Word; + inetNNTPUse : Boolean; + inetNNTPPort : Word; + inetNNTPMax : Word; + inetNNTPDupes : Byte; + // UNSORTED + Reserved : Array[1..491] of Char; + End; + +Const + UserLockedOut = $01; + UserNoRatio = $02; + UserDeleted = $04; + UserNoKill = $08; + UserNoCaller = $10; + UserNoPWChange = $20; + +//FUTURE DATA FILE UPDATES NEEDED +//LASTON needs optional1-10 compare to Mystic2 +//FBASE +// ACS to comment on file +//FDIR +// pointer to comments record +// rating moved here from comment record +// file deletes and mbbsutil need updating to deal with comments +//MBASES +// expand header filename[20] +// add template[20] +// add msgbase sponser[30] +// add newsname[80] +// add colorkludge[b] +// add flags[l] merge in useReal +// flags: +// userealname, forced, allow autosig, allow attachments, kludge filter +// remove password? +// ACS to s[30] +//MENUS +// remove fallback? +// (flags) +// menu descriptions +// node action +// command timer +// input chars +// (commands) +// TBD compare to mystic 2 +// VOTING: expand ACS to s[30] +// LANGREC +// example path sizes +// add script path? +// compare to mystic 2 for fallback stuff? +// rename to THEME + +Type + RecUser = Record { USERS.DAT } + PermIdx : LongInt; // permanent user number + Flags : Byte; { User Flags } + Handle : String[30]; { Handle } + RealName : String[30]; { Real Name } + Password : String[15]; { Password } + Address : String[30]; { Address } + City : String[25]; { City } + ZipCode : String[9]; { Zipcode } + HomePhone : String[15]; { Home Phone } + DataPhone : String[15]; { Data Phone } + Birthday : LongInt; + Gender : Char; { M> Male F> Female } + Email : String[60]; { email address } + Optional : Array[1..10] of String[60]; + UserInfo : String[30]; { user comment field } + Theme : String[20]; { user's language file } + AF1 : AccessFlagType; + AF2 : AccessFlagType; { access flags set #2 } + Security : SmallInt; { Security Level } + Expires : String[8]; + ExpiresTo : Byte; + LastPWChange : String[8]; + StartMenu : String[20]; { Start menu for user } + Archive : String[4]; { default archive extension } + QwkFiles : Boolean; { Include new files in QWK? } + DateType : Byte; { Date format (see above) } + ScreenSize : Byte; { user's screen length } + ScreenCols : Byte; + PeerIP : String[20]; + PeerName : String[50]; + FirstOn : LongInt; { Date/Time of First Call } + LastOn : LongInt; { Date/Time of Last Call } + Calls : LongInt; { Number of calls to BBS } + CallsToday : SmallInt; { Number of calls today } + DLs : SmallInt; { # of downloads } + DLsToday : SmallInt; { # of downloads today } + DLk : LongInt; { # of downloads in K } + DLkToday : LongInt; { # of downloaded K today } + ULs : LongInt; { total number of uploads } + ULk : LongInt; { total number of uploaded K } + Posts : LongInt; { total number of msg posts } + Emails : LongInt; { total number of sent email } + TimeLeft : LongInt; { time left online for today } + TimeBank : SmallInt; { number of mins in timebank } + FileRatings : LongInt; + FileComment : LongInt; + LastFBase : Word; { Last file base } + LastMBase : Word; { Last message base } + LastMGroup : Word; { Last group accessed } + LastFGroup : Word; { Last file group accessed } + Vote : Array[1..mysMaxVoteQuestion] of Byte; { Voting booth data } + EditType : Byte; { 0 = Line, 1 = Full, 2 = Ask } + FileList : Byte; { 0 = Normal, 1 = Lightbar } + SigUse : Boolean; { Use auto-signature? } + SigOffset : LongInt; { offset to sig in AUTOSIG.DAT } + SigLength : Byte; { number of lines in sig } + HotKeys : Boolean; { does user have hotkeys on? } + MReadType : Byte; { 0 = line 1 = full 2 = ask } + UseLBIndex : Boolean; { use lightbar index? } + UseLBQuote : Boolean; { use lightbar quote mode } + UseLBMIdx : Boolean; { use lightbar index in email? } + UseFullChat : Boolean; { use full screen teleconference } + Credits : LongInt; + Reserved : Array[1..393] of Byte; + End; + + EventRec = Record { EVENTS.DAT } + Active : Boolean; { Is event active? } + Name : String[30]; { Event Name } + Forced : Boolean; { Is this a forced event } + ErrLevel : Byte; { Errorlevel to Exit } + ExecTime : SmallInt; { Minutes after midnight } + Warning : Byte; { Warn user before the event } + Offhook : Boolean; { Offhook modem for event? } + Node : Byte; { Node number. 0 = all } + LastRan : LongInt; { Last time event was ran } + End; + +(* SECURITY.DAT in the data directory holds 255 records, one for each *) +(* possible security level. *) + + RecSecurity = Record { SECURITY.DAT } + Desc : String[30]; { Description of security level } + Time : SmallInt; { Time online (mins) per day } + MaxCalls : SmallInt; { Max calls per day } + MaxDLs : SmallInt; { Max downloads per day } + MaxDLk : SmallInt; { Max download kilobytes per day } + MaxTB : SmallInt; { Max mins allowed in time bank } + DLRatio : Byte; { Download ratio (# of DLs per UL) } + DLKRatio : SmallInt; { DL K ratio (# of DLed K per UL K } + AF1 : AccessFlagType; { Access flags for this level A-Z } + AF2 : AccessFlagType; { Access flags #2 for this level } + Hard : Boolean; { Do a hard AF upgrade? } + StartMenu : String[20]; { Start Menu for this level } + PCRatio : SmallInt; { Post / Call ratio per 100 calls } + Expires : Word; + ExpiresTo : Word; + Posts : Word; + PostsTo : Word; + Download : Word; + DownloadTo : Word; + Upload : Word; + UploadTo : Word; + Calls : Word; + CallsTo : Word; + Reserved : Array[1..64] of Byte; + End; + + RecArchive = Record { ARCHIVE.DAT } + OSType : Byte; + Active : Boolean; + Desc : String[30]; + Ext : String[4]; + Pack : String[80]; + Unpack : String[80]; + View : String[80]; + End; + + MScanRec = Record { *.SCN } + NewScan : Byte; { Include this base in new scan? } + QwkScan : Byte; { Include this base in qwk scan? } + End; + + MBaseRec = Record { MBASES.DAT } + Name : String[40]; { Message base name } + QWKName : String[13]; { QWK (short) message base name } + FileName : String[40]; { Message base file name } + Path : String[40]; { Path where files are stored } + BaseType : Byte; { 0 = JAM, 1 = Squish } + NetType : Byte; { 0 = Local 1 = EchoMail } + { 2 = UseNet 3 = NetMail } + PostType : Byte; { 0 = Public 1 = Private } + ACS, { ACS required to see this base } + ReadACS, { ACS required to read messages } + PostACS, { ACS required to post messages } + SysopACS : String[20]; { ACS required for sysop options } + Password : String[15]; { Password for this message base } + ColQuote : Byte; { Quote text color } + ColText : Byte; { Text color } + ColTear : Byte; { Tear line color } + ColOrigin: Byte; { Origin line color } + NetAddr : Byte; { Net AKA to use for this base } + Origin : String[50]; { Net origin line for this base } + UseReal : Boolean; { Use real names? } + DefNScan : Byte; { 0 = off, 1 = on, 2 = always } + DefQScan : Byte; { 0 = off, 1 = on, 2 = always } + MaxMsgs : Word; { Max messages to allow } + MaxAge : Word; { Max age of messages before purge } + Header : String[8]; { Display Header file name } + Index : SmallInt; { QWK index - NEVER CHANGE THIS } + End; + + FScanRec = Record { *.SCN } + NewScan : Byte; { Include this base in new scan? } + LastNew : LongInt; { Last file scan (packed datetime)} + End; + + FBaseRec = Record { FBASES.DAT } + Name : String[40]; { File base name } + FtpName : String[60]; { FTP directory name } + Filename : String[40]; { File name } + DispFile : String[20]; { Pre-list display file name } + Template : String[20]; { ansi file list template } + ListACS, { ACS required to see this base } + FtpACS, { ACS to see in FTP directory } + SysopACS, { ACS required for SysOp functions} + ULACS, { ACS required to upload files } + DLACS : String[mysMaxAcsSize]; { ACS required to download files } + Path : String[120]; { Path where files are stored } + Password : String[20]; { Password to access this base } + DefScan : Byte; { Default New Scan Setting } + ShowUL : Boolean; + IsCDROM : Boolean; + IsFREE : Boolean; + End; + // make flags and merge in shouul, iscdrom,isfree, etc + +(* The file directory listing are stored as .DIR in *) +(* the data directory. Each record stores the info on one file. File *) +(* descriptions are stored in .DES in the data *) +(* directory. FDirRec.Pointer points to the file position in the .DES *) +(* file where the file description for the file begins. FDirRec.Lines is *) +(* the number of lines in the file description. Each line is stored as a *) +(* Pascal-like string (ie the first byte is the length of the string, *) +(* followed by text which is the length of the first byte *) + +Const + FDirOffline = $01; + FDirInvalid = $02; + FDirDeleted = $04; + FDirFailed = $08; + FDirFree = $10; + +Type + FDirRec = Record { *.DIR } + FileName : String[70]; { File name } + Size : LongInt; { File size (in bytes) } + DateTime : LongInt; { Date and time of upload } + Uploader : String[30]; { User name who uploaded the file } + Flags : Byte; { Set of FDIRFLAGS (see above) } + Pointer : LongInt; { Pointer to file description } + Lines : Byte; { Number of description lines } + DLs : Word; { # of times this file was downloaded} + End; + + FDirCommentRec = Record { .FCI and .FCT in DATA directory } + UserName : String[30]; + Rating : Byte; + Date : LongInt; + Lines : Word; + End; + + RecGroup = Record { GROUP_*.DAT } + Name : String[30]; { Group name } + ACS : String[30]; { ACS required to access group } + Hidden : Boolean; + End; + +(* Mystic BBS stores it's menu files as text files. They *) +(* have been stored this way to make it possible to edit them with a text *) +(* editor (which is sometimes easier then using the menu editor). The *) +(* following records do not need to be used, but provide one way of *) +(* reading a menu into a record. *) + + MenuRec = Record + Header : String[255]; + Prompt : String[255]; + DispCols : Byte; + ACS : String[20]; + Password : String[15]; + TextFile : String[8]; + FallBack : String[8]; + MenuType : Byte; { 0 = standard, 1 = lightbar, 2 = lightbar grid } + InputType : Byte; { 0 = user setting, 1 = longkey, 2 = hotkey } + DoneX : Byte; + DoneY : Byte; + Global : Byte; { 0 = no, 1 = yes } + End; + + MenuCmdRec = Record + Text : String[79]; + HotKey : String[8]; + LongKey : String[8]; + ACS : string[20]; + Command : String[2]; + Data : String[79]; + X : Byte; + Y : Byte; + cUp : Byte; + cDown : Byte; + cLeft : Byte; + cRight : Byte; + LText : String[79]; + LHText : String[79]; + End; + + PercentRec = Record // percentage bar record + BarLen : Byte; + LoChar : Char; + LoAttr : Byte; + HiChar : Char; + HiAttr : Byte; + End; + + LangRec = Record { LANGUAGE.DAT } + FileName : String[8]; { Language file name } + Desc : String[30]; { Language description } + TextPath : String[40]; { Path where text files are stored } + MenuPath : String[40]; { Path where menu files are stored } + okASCII : Boolean; { Allow ASCII } + okANSI : Boolean; { Allow ANSI } + BarYN : Boolean; { Use Lightbar Y/N with this lang } + FieldCol1 : Byte; { Field input color } + FieldCol2 : Byte; + FieldChar : Char; + EchoCh : Char; { Password echo character } + QuoteColor : Byte; { Color for quote lightbar } + TagCh : Char; { File Tagged Char } + FileHi : Byte; { Color of file search highlight } + FileLo : Byte; { Non lightbar description color } + NewMsgChar : Char; { Lightbar Msg Index New Msg Char } + VotingBar : PercentRec; { voting booth bar } + FileBar : PercentRec; { file list bar } + MsgBar : PercentRec; { lightbar msg reader bar } + GalleryBar : PercentRec; + Reserved : Array[1..95] of Byte; { RESERVED } + End; + + BBSListRec = Record + cType : Byte; + Phone : String[15]; + Telnet : String[40]; + BBSName : String[30]; + Location : String[25]; + SysopName : String[30]; + BaudRate : String[6]; + Software : String[10]; + Deleted : Boolean; + AddedBy : String[30]; + Verified : LongInt; + Res : Array[1..6] of Byte; + End; + +(* ONELINERS.DAT found in the data directory. This file contains all the + one-liner data. It can be any number of records in size. *) + + OneLineRec = Record + Text : String[79]; + From : String[30]; + End; + +(* Each record of VOTES.DAT is one question. Mystic only allows for up *) +(* to 20 questions. *) + + VoteRec = Record { VOTES.DAT in DATA directory } + Votes : SmallInt; { Total votes for this question } + AnsNum : Byte; { Total # of Answers } + User : String[30]; { User name who added question } + ACS : String[20]; { ACS to see this question } + AddACS : String[20]; { ACS to add an answer } + ForceACS : String[20]; { ACS to force voting of question } + Question : String[79]; { Question text } + Answer : Array[1..15] of Record { Array[1..15] of Answer data } + Text : String[40]; { Answer text } + Votes : SmallInt; { Votes for this answer } + End; + End; + +(* CHATx.DAT is created upon startup, where X is the node number being *) +(* loaded. These files are used to store all the user information for a *) +(* node. *) + + ChatRec = Record { CHATx.DAT } + Active : Boolean; { Is there a user on this node? } + Name : String[30]; { User's name on this node } + Action : String[40]; { User's action on this node } + Location : String[30]; { User's City/State on this node } + Gender : Char; { User's gender } + Age : Byte; { User's age } + Baud : String[6]; { User's baud rate } + Invisible : Boolean; { Is node invisible? } + Available : Boolean; { Is node available? } + InChat : Boolean; { Is user in multi-node chat? } + Room : Byte; { Chat room } + End; + +(* Chat room record - partially used by the multi node chat functions *) + + RoomRec = Record + Name : String[40]; { Channel Name } + Reserved : Array[1..128] of Byte; { RESERVED } + End; + +(* CALLERS.DAT holds information on the last ten callers to the BBS. This *) +(* file is always 10 records long with the most recent caller being the *) +(* 10th record. *) + + LastOnRec = Record { CALLERS.DAT } + Handle : String[30]; { User's Name } + City : String[25]; { City/State } + Address : String[30]; { user's address } + Baud : String[6]; { Baud Rate } + DateTime : LongInt; { Date & Time (UNIX) } + Node : Byte; { Node number of login } + CallNum : LongInt; { Caller Number } + EmailAddr : String[35]; { email address } + UserInfo : String[30]; { user info field } + Option1 : String[35]; { optional data 1 } + Option2 : String[35]; { " " 2 } + Option3 : String[35]; { " " 3 } + End; + + HistoryRec = Record + Date : LongInt; + Emails : Word; + Posts : Word; + Downloads : Word; + Uploads : Word; + DownloadKB : LongInt; + UploadKB : LongInt; + Calls : LongInt; + NewUsers : Word; + End; + + RecProtocol = Record + OSType : Byte; + Active : Boolean; + Batch : Boolean; + Key : Char; + Desc : String[40]; + SendCmd : String[60]; + RecvCmd : String[60]; + End; + + PromptRec = String[255]; + + NodeMsgRec = Record + FromNode : Byte; + FromWho : String[30]; + ToWho : String[30]; + Message : String[250]; + MsgType : Byte; + { 1 = Chat Pub and broadcast } + { 2 = System message } + { 3 = User message } + { 4 = Chat Private } + { 5 = chat status note } + { 6 = chat action } + { 7 = chat topic update } + Room : Byte; { Chat room number. 0 = chat broadcast } + End;