Category : Pascal Source Code
Archive   : LTCOMM50.ZIP
Filename : LCDEMO.PAS

 
Output of file : LCDEMO.PAS contained in archive : LTCOMM50.ZIP
{$A-,B-,D-,E+,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 16384,0,655360}
PROGRAM LCDEMO;
(*
** LCDEMO is Copyright (c) 1989, Information Technology Ltd.
** -- All Rights Reserved --
**
** Note: To recompile this program, you must have Technojock's Turbo Toolkit
** by TechnoJock Software, Inc; PO Box 820927, Houston, TX 77282
**
*)

USES Crt, Dos, Printer, FastTTT5, IOTTT5, KeyTTT5, MiscTTT5, NestTTT5, ReadTTT5,
StrnTTT5, WinTTT5, LctKrnl, LctSupp, LctYMBat, LTXmKrnl, LTXmodem;

TYPE
BytePtr = ^BYTE;

PtrRec = RECORD
Ofs, Seg : WORD;
END;

ConfigRec = RECORD
ComPort : INTEGER;
BaudRate : WORD;
Parity : CHAR;
DataBits : INTEGER;
StopBits : INTEGER;
Changed : BOOLEAN;
END;

VAR
Main_Menu : Nest_Menu;
Desk_Menu : Nest_Menu;
Dnl_Menu : Nest_Menu;
Upl_Menu : Nest_Menu;
Opt_Menu : Nest_Menu;
Port_Menu : Nest_Menu;
Set_Menu : Nest_Menu;
Quit_Menu : Nest_Menu;

HostMode : BOOLEAN;
LocalEcho : BOOLEAN;
ExitActive : BOOLEAN;
GotEsc : BOOLEAN;

CurrConfig : ConfigRec;
CfgFile : FILE OF ConfigRec;

XMBlksize : INTEGER;

PROCEDURE ShowPortStatus;
VAR
X, Y, Top, Bottom : BYTE;
DispStr : STRING;
WkStr : STRING[18];

BEGIN
WITH CurrConfig DO
BEGIN
FindCursor(X, Y, Top, Bottom);
OffCursor;
CASE ComPort OF
1 : DispStr := 'COM1,';
2 : DispStr := 'COM2,';
3 : DispStr := 'COM3,';
4 : DispStr := 'COM4,';
END;
WkStr := Int_to_Str(BaudRate);
DispStr := DispStr + WkStr + ',' + Parity + ',';
WkStr := Int_to_Str(DataBits);
DispStr := DispStr + WkStr + ',';
WkStr := Int_to_Str(StopBits);
DispStr := DispStr + WkStr;
PlainWrite(40, 25, DispStr);
PosCursor(X, Y);
OnCursor;
END (* with *);
END (* ShowPortStatus *);

PROCEDURE ChangePort(NewPort : INTEGER);
VAR
dbool : BOOLEAN;

BEGIN
WITH CurrConfig DO
BEGIN
CommClose(ComPort, FALSE);
ComPort := NewPort;
dbool := CommOpen(ComPort, BaudRate, Parity, DataBits, StopBits, 2048, 2048, TRUE);
Changed := TRUE;
END (* with *);
ShowPortStatus;
END (* ChangePort *);

PROCEDURE SetPort(Choice : INTEGER);
VAR
dbool : BOOLEAN;
Ch : CHAR;

BEGIN
WITH CurrConfig DO
BEGIN
CASE Choice OF
50..51 : BaudRate := 1200;
52..53 : BaudRate := 2400;
54..55 : BaudRate := 9600;
56..57 : BaudRate := 19200;
END (* case *);
IF Choice <= 57 THEN (* using menu pre-sets ? *)
BEGIN
Changed := TRUE;
IF (Choice MOD 2) = 0 THEN
BEGIN
Parity := 'N';
DataBits := 8;
END
ELSE
BEGIN
Parity := 'E';
DataBits := 7;
END;
StopBits := 1;
END
ELSE
TempMessageBoxCh(20, 12, WHITE, RED, 2, 'Sorry...That function isn''t available', Ch);

dbool := CommSetup(ComPort, BaudRate, Parity, DataBits, StopBits);
END (* with *);
ShowPortStatus;
END (* SetPort *);


PROCEDURE ShowInfoBox;
BEGIN
GrowMkWin(21, 8, 55, 15, Black, Green, 1); (* open up the window *)
PlainWrite(26, 9, 'FileName:');
PlainWrite(28, 11, 'Blocks:');
PlainWrite(28, 12, 'Errors:');
PlainWrite(22, 13, 'Total Errors:');
END (* ShowInfoBox *);

{$F+}
PROCEDURE ShowFile(CPort: INTEGER; Name:STRING);
BEGIN
PlainWrite(36, 9, ' ');
PlainWrite(36, 9, Name);
END (* ShowFile *);

PROCEDURE ShowXferData(CPort:INTEGER; Rec, Errors, TotErrors:WORD);
VAR
WString : STRING;

BEGIN
WString := Int_to_Str(Rec+1);
PlainWrite(36, 11, WString);
WString := Int_to_Str(Errors);
PlainWrite(36, 12, WString);
WString := Int_to_Str(TotErrors);
PlainWrite(36, 13, WString);
END (* ShowXferData *);

FUNCTION ChkKbd : BOOLEAN;
VAR
Ch : CHAR;

BEGIN
ChkKbd := FALSE;
IF KeyPressed THEN
BEGIN
Ch := ReadKey;
IF Ch = #$00 THEN
Ch := ReadKey;
END;
IF Ch = #$1B THEN
ChkKbd := TRUE;
END (* ChkKbd *);

PROCEDURE Test_Esc(VAR Ch:CHAR; VAR ID:BYTE; VAR REFRESH:BYTE);
BEGIN
GotEsc := FALSE;
REFRESH := Refresh_None;
IF Ch = Esc THEN
BEGIN
GotEsc := TRUE;
REFRESH := End_Input;
END;
END (* Test_Esc *);

PROCEDURE Leave_Tab1(VAR ID:BYTE; VAR R:BYTE);
BEGIN
IF ID = 7 THEN
R := End_Input;
END (* Leave_Tab1 *);

PROCEDURE Leave_Tab2(VAR ID:BYTE; VAR R:BYTE);
BEGIN
R := End_Input;
END (* Leave_Tab1 *);

PROCEDURE Leave_Tab5(VAR ID:BYTE; VAR R:BYTE);
BEGIN
IF ID = 3 THEN
R := End_Input;
END (* Leave_Tab1 *);

{$F-}

PROCEDURE LcInfo;
BEGIN
CreateScreen(2,25); (* start a virtual screen *)
Activate_Virtual_Screen(2);
FBox(1, 1, 80, 25, BLACK, CYAN, 4);
WriteCenter(2, BLACK, GREEN, 'INTRODUCING LITECOMM');
WriteAT(6, 4, BLACK, CYAN,
'LiteComm (Tm) and LiteComm-TP are sophisticated toolboxes of proven');
WriteAT(6, 5, BLACK, CYAN,
'routines for C and PASCAL programmers. By using LiteComm, you can');
WriteAT(6, 6, BLACK, CYAN,
'quickly and easily add communications capabilities to your application');
WriteAT(6, 7, BLACK, CYAN,
'without worrying about the details.');
WriteAT(6, 9, BLACK, CYAN,
'LiteComm is a shareware product. If you find the package useful, you');
WriteAT(6, 10, BLACK, CYAN,
'must register it. Full registration information is contained in the');
WriteAT(6, 11, BLACK, CYAN,
'documentation, or you may complete the online registration form.');
WriteCenter(13, BLACK, GREEN,
'LiteComm and LiteComm-TP are Copyright (c) 1987,88,89');
WriteCenter(14, BLACK, GREEN,
'Information Technology, Ltd.; all rights reserved');
WriteAT(35, 16, BLACK, CYAN, 'ÚÄÄÄÄÄ¿');
WriteAT(31, 17, BLACK, CYAN, 'ÚÄÄÄÁÄ¿ ³ (Tm)');
WriteAT(29, 18, BLACK, CYAN, 'ÄÄ´ ³o ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
WriteAT(31, 19, BLACK, CYAN, '³ ÚÄÄÄÁÁ¿ ³ Association of');
WriteAT(31, 20, BLACK, CYAN, '³ ³ ÃÄÙ Shareware');
WriteAT(31, 21, BLACK, CYAN, 'ÀÄ´ o ³ Professionals');
WriteAT(29, 22, BLACK, CYAN, 'ÄÄÄĵ ³ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
WriteAT(33, 23, BLACK, CYAN, 'ÀÄÄÁÄÄÙ MEMBER');
Activate_Visible_Screen;
SaveScreen(1);
SlideRestoreScreen(2, Left);
REPEAT
;
UNTIL ChkKbd;
SlideRestoreScreen(1, Up);
END (* LcInfo *);

PROCEDURE LcReg;
VAR
Name,
Company,
Address : STRING[35];
City,
Country : STRING[20];
State : STRING[2];
PostCode,
DayPhone : STRING[15];
ByCheck,
ByVISA,
ByMC : STRING[1];
CCNumber: STRING[16];
ExpDate : DATES;

BEGIN
(*
** init the world
*)
Name := '';
Company := '';
Address := '';
City := '';
Country := '';
State := '';
PostCode := '';
ByCheck := '';
ByVISA := '';
ByMC := '';
DayPhone := '';
CCNumber := '';
ExpDate := 0;

MkWin(1, 1, 80, 25, BLACK, CYAN, 2); (* double line box window *)
WriteCenter(3, BLACK, GREEN, 'LITECOMM (Tm) REGISTRATION');
WriteAT(11, 5, BLACK, CYAN,
'Complete the following information. I will print a completed');
WriteAT(11, 6, BLACK, CYAN,
'registration form for you to mail. (ESC to abort)');
WriteAT(11, 8, BLACK, CYAN, 'NAME');
WriteAT(57, 8, BLACK, GREEN, '(from credit card)');
WriteAT(11, 10, BLACK, CYAN, 'COMPANY');
WriteAT(11, 12, BLACK, CYAN, 'ADDRESS');
WriteAT(11, 14, BLACK, CYAN, 'CITY');
WriteAT(41, 14, BLACK, CYAN, 'STATE');
WriteAT(11, 16, BLACK, CYAN, 'COUNTRY');
WriteAT(41, 16, BLACK, CYAN, 'POSTAL CODE');
WriteAT(11, 18, BLACK, CYAN, 'Method of Payment ($50 Fee)');
WriteAT(13, 20, BLACK, CYAN, '[ ] Check Enclosed');
WriteAT(13, 22, BLACK, CYAN, '[ ] VISA [ ] MasterCard NO:');
WriteAT(64, 22, BLACK, CYAN, 'EXPIRES');
WriteAT(13, 23, BLACK, CYAN, 'Daytime Telephone');

Create_Tables(5);

Activate_Table(1); (* table 1 is basic info *)
Allow_Esc(TRUE);
Create_Fields(7);
Add_Field(1, 1, 2, 1, 2, 20, 8); (* Name *)
Add_Field(2, 1, 3, 2, 3, 20, 10); (* Company *)
Add_Field(3, 2, 4, 3, 4, 20, 12); (* Address *)
Add_Field(4, 3, 5, 4, 5, 20, 14); (* City *)
Add_Field(5, 4, 6, 5, 6, 47, 14); (* State *)
Add_Field(6, 5, 7, 6, 7, 20, 16); (* Country *)
Add_field(7, 6, 7, 7, 7, 53, 16); (* postal code *)
String_Field(1, Name, '***********************************');
String_Field(2, Company, '***********************************');
String_Field(3, Address, '***********************************');
String_Field(4, City, '********************');
String_Field(5, State, '!!');
String_Field(6, Country, '********************');
String_Field(7, PostCode, '***************');

Activate_Table(2);
Allow_Esc(TRUE);
Create_Fields(1);
Add_Field(1, 1, 1, 1, 1, 14, 20); (* pay by check *)
String_Field(1, ByCheck, '!');
Field_Rules(1, JumpIfFull, [' ', 'X', 'x'], [No_Char]);
Add_Message(1, 1, 25, 'X to Select, SPACE to Skip');

Activate_Table(3);
Allow_Esc(TRUE);
Create_Fields(1);
Add_Field(1, 1, 1, 1, 1, 14, 22); (* pay by visa *)
String_Field(1, ByVISA, '!');
Field_Rules(1, JumpIfFull, [' ', 'X', 'x'], [No_Char]);
Add_Message(1, 1, 25, 'X to Select, SPACE to Skip');

Activate_Table(4);
Allow_Esc(TRUE);
Create_Fields(1);
Add_Field(1, 1, 1, 1, 1, 24, 22); (* pay by M/C *)
String_Field(1, ByMC, '!');
Field_Rules(1, JumpIfFull, [' ', 'X', 'x'], [No_Char]);
Add_Message(1, 1, 25, 'X to Select, SPACE to Skip');

Activate_Table(5);
Allow_Esc(TRUE);
Create_Fields(3);
Add_Field(1, 1, 2, 1, 2, 43, 22);
Add_Field(2, 1, 3, 2, 3, 72, 22);
Add_Field(3, 2, 3, 3, 3, 31, 23);
String_Field(1, CCNumber, '####-####-####-####');
Date_Field(2, ExpDate, MMYY, '##/##', 0, 0);
String_Field(3, DayPhone, '***************');
Field_Rules(1, JumpIfFull, [No_Char], [No_Char]);
Field_Rules(2, JumpIfFull, [No_Char], [No_Char]);
Field_Rules(3, JumpIfFull, [No_Char], [No_Char]);
Add_Message(3, 1, 25, 'Daytime Telephone Number');

(* Basic Data *)
Activate_Table(1);
Assign_CharHook(Test_Esc);
Assign_LeaveFieldHook(Leave_Tab1);
Process_Input(1);
IF GotEsc THEN
BEGIN
Dispose_Fields;
Dispose_Tables;
RmWin;
EXIT;
END;

REPEAT
ByCheck := '';
ByVISA := '';
ByMC := '';

(* By Check *)
Activate_Table(2);
Assign_CharHook(Test_Esc);
Assign_LeaveFieldHook(Leave_Tab2);
String_Field(1, ByCheck, '!'); (* force default reset *)
Process_Input(1);

(* By VISA *)
IF (ByCheck <> 'X') AND
(NOT GotEsc) THEN
BEGIN
Activate_Table(3);
Assign_CharHook(Test_Esc);
Assign_LeaveFieldHook(Leave_Tab2);
String_Field(1, ByVISA, '!');
Process_Input(1);
END;

(* By MC *)
IF (ByCheck <> 'X') AND
(ByVISA <> 'X') AND
(NOT GotEsc ) THEN
BEGIN
Activate_Table(4);
Assign_CharHook(Test_Esc);
Assign_LeaveFieldHook(Leave_Tab2);
String_Field(1, ByMC, '!');
Process_Input(1);
END;
UNTIL (ByCheck = 'X') OR
(ByVISA = 'X') OR
(ByMC = 'X') OR
(GotEsc);
IF GotEsc THEN
BEGIN
Dispose_Fields;
Dispose_Tables;
RmWin;
EXIT;
END;


(* Credit Card Info *)
IF (BYCheck <> 'X') AND
(NOT GotEsc) THEN
BEGIN
Activate_Table(5);
Assign_CharHook(Test_Esc);
Assign_LeaveFieldHook(Leave_Tab5);
Process_Input(1);
IF GotEsc THEN
BEGIN
Dispose_Fields;
Dispose_Tables;
RmWin;
EXIT;
END;
END;

(*
** Print the actual form
*)
Writeln(Lst, ' LiteComm - TP REGISTRATION');
Writeln(Lst);
Writeln(Lst);
Writeln(Lst);
Writeln(Lst, 'Please register my copy of the LiteComm-TP ToolBox.');
Writeln(Lst, 'I Agree to be bound by the terms and conditions of the');
Writeln(Lst, 'license agreement as stated in the LiteComm-TP documentation');
Writeln(Lst);
Writeln(Lst);
Writeln(Lst,' Name: ', Name);
Writeln(Lst,' Company: ', Company);
Writeln(Lst,' Address: ', Address);
Writeln(Lst,' City: ', City, ' State: ', State);
IF Length(Country) > 0 THEN
Write(Lst,' Country: ', Country, ' ');
Writeln(Lst, 'Postal Code: ', PostCode);
Writeln(Lst);
Writeln(Lst, 'Payment by:');
IF ByCheck = 'X' THEN
Writeln(Lst, ' Check Enclosed')
ELSE
IF ByVISA = 'X' THEN
Writeln(Lst, ' VISA No: ', CCNumber, ' Expires',
Julian_to_Date(ExpDate, MMYY))
ELSE
Writeln(Lst, ' MasterCard No: ', CCNumber, ' Expires',
Julian_to_Date(ExpDate, MMYY));
IF ByCheck <> 'X' THEN
BEGIN
Writeln(Lst, ' Daytime Phone Number: ', DayPhone);
Writeln(Lst);
Writeln(Lst);
Writeln(Lst, 'Signature(required)..............................................');
END;
Writeln(Lst);
Writeln(Lst,'Send to: Information Technology, Ltd');
Writeln(Lst,' PO Box 554');
Writeln(Lst,' Coventry, RI 02816');
Write(Lst, #$0C); (* FORM-FEED *)

Dispose_Fields;
Dispose_Tables;
RmWin;
END (* LcReg *);

PROCEDURE Downl_XM;
VAR
dbool : BOOLEAN;
X, Y, Top, Bottom : BYTE;
Path : PathStr;

BSize : WORD;
RBSize : INTEGER;
HandShake : BYTE;
BPtr : BytePtr;
CRPtr : BytePtr;
Result : XMResult;
BytesRem : WORD; (* number of untrans. bytes *)
XMFile : FILE;

BEGIN
Path := '';
SaveScreen(1);
Read_String(3, 12, 70, '_File Name to Get, Esc to EXIT', 1, Path);
RestoreScreen(1);
IF R_Char = Esc THEN
EXIT;

FindCursor(X, Y, Top, Bottom);
OffCursor;
ShowInfoBox;
(*
** Install Hooks For the display Routines
*)

dbool := SetFnHook(CurrConfig.ComPort, ShowFile);
dbool := SetUserHook(CurrConfig.ComPort, ShowXferData);
dbool := SetAbortHook(CurrConfig.ComPort, ChkKbd);

BSize := 8192; (* want to use 8K buffer *)
BPtr := NIL;
WHILE (BPtr = NIL) AND (* allocate buffer for proc *)
(BSize > 0) DO
IF MaxAvail >= BSize THEN (* enough contig space *)
GetMem(BPtr, BSize) (* yes, grab it *)
ELSE
DEC(BSize, 1024); (* no, try 1K less *)

(*
** Here is where everything begins...All XModem related code is
** self-contained here
*)

Assign(XMFile, Path);
ShowFnProc[CurrConfig.ComPort](CurrConfig.ComPort, Path);
{$I-}
Rewrite(XMFile, 1);
{$I+}
IF IOResult <> 0 THEN
FlagAbort(CurrConfig.ComPort);

Result := Success;
BytesRem := 0;
CRPtr := BPtr;

HandShake := CRCREQ; (* receive in CRC mode *)
XMReset(CurrConfig.ComPort);
BatchMode(CurrConfig.ComPort, FALSE);

WHILE Result = Success DO
BEGIN
Result := LxmRrec(CurrConfig.ComPort, CRPtr^, RBSize, RTOUT, HandShake);
IF Result = Success THEN
BEGIN
INC(BytesRem, RBSize);
INC(PtrRec(CRPtr).Ofs, RBSize);
IF BytesRem >= BSize THEN (* filled the IO Buffer *)
BEGIN
{$I-}
BlockWrite(XMFile, BPtr^, BSize);
{$I+}
IF IOResult <> 0 THEN
FlagAbort(CurrConfig.ComPort);
CRPtr := BPtr; (* set current record ptr *)
BytesRem := 0;
END;
END;
IF Result = DupBlk THEN
Result := Success;
END (* while *);
IF (BytesRem > 0) AND (* anything left unwritten *)
(Result = EndFile) THEN (* Is it End of File ? *)
BlockWrite(XMFile, BPtr^, BytesRem); (* yes, flush the buffer *)

Close(XMFile);
BatchMode(CurrConfig.ComPort, FALSE);
Dispose(BPtr);
XMReset(CurrConfig.ComPort);

IF Result <> EndFile THEN (* if we didn't end OK *)
Erase(XMFile);

RmWin;
OnCursor;
PosCursor(X, Y);
END (* Downl_XM *);

PROCEDURE Send_XM;
VAR
Path : PathStr;
X, Y, Top, Bottom : BYTE;
BSize : WORD;
BPtr : BytePtr;
CRPtr : BytePtr;
Result : XMResult;
BytesRead, (* number of bytes read *)
BytesRem : WORD; (* number of untrans. bytes *)
XMFile : FILE;

BEGIN
Path := '';
SaveScreen(1);
Read_String(3, 12, 70, '_File Spec to Send, Esc to EXIT', 1, Path);
RestoreScreen(1);
IF R_Char = Esc THEN
EXIT;

FindCursor(X, Y, Top, Bottom);
OffCursor;
ShowInfoBox;

BSize := 8192; (* want to use 8K buffer *)
BPtr := NIL;
WHILE (BPtr = NIL) AND (* allocate buffer for proc *)
(BSize > 0) DO
IF MaxAvail >= BSize THEN (* enough contig space *)
GetMem(BPtr, BSize) (* yes, grab it *)
ELSE
DEC(BSize, 1024); (* no, try 1K less *)

Assign(XMFile, Path);
ShowFnProc[CurrConfig.ComPort](CurrConfig.ComPort, Path);
{$I-}
Reset(XMFile, 1);
{$I+}
FillChar(BPtr^, XMBlksize, $00); (* prefill buffer w/ nulls *)

Result := Success;
BytesRead := 1;

WHILE (BytesRead > 0) AND

(Result = Success) DO
BEGIN
FillChar(BPtr^, BSize, $00);
{$I-}
BlockRead(XMFile, BPtr^, BSize, BytesRead);
{$I+}
CRPtr := BPtr; (* set current record ptr *)
BytesRem := BytesRead;

WHILE (BytesRem > 0) AND
(Result = Success) DO
BEGIN
Result := LxmTrec(CurrConfig.ComPort, CRPtr^); (* do actual transmission *)
IF BytesRem > XMBlksize THEN
DEC(BytesRem, XMBlksize)
ELSE
BytesRem := 0;
INC(PtrRec(CRPtr).Ofs, XMBlksize);
END;

IF BytesRead < BSize THEN
BytesRead := 0;
END; (* OUTER WHILE *)

IF Result = Success THEN
Result := LxmTeot(CurrConfig.ComPort); (* send end of file *)
Close(XMFile);
Dispose(BPtr); (* release buffer *)

RmWin;
OnCursor;
PosCursor(X, Y);
END;


PROCEDURE Downl_YM;
VAR
dbool : BOOLEAN;
X, Y, Top, Bottom : BYTE;

BEGIN
FindCursor(X, Y, Top, Bottom);
OffCursor;
ShowInfoBox;
(*
** Install Hooks For the display Routines
*)

dbool := SetFnHook(CurrConfig.ComPort, ShowFile);
dbool := SetUserHook(CurrConfig.ComPort, ShowXferData);
dbool := SetAbortHook(CurrConfig.ComPort, ChkKbd);
dbool := LctYMRecv(CurrConfig.ComPort);

RmWin;
OnCursor;
PosCursor(X, Y);
END (* Downl_YM *);

PROCEDURE Upl_YM;
VAR
dbool : BOOLEAN;
X, Y, Top, Bottom : BYTE;
Path : PathStr;

BEGIN
Path := '';
SaveScreen(1);
Read_String(3, 12, 70, '_File Spec to Send, Esc to EXIT', 1, Path);
RestoreScreen(1);
IF R_Char = Esc THEN
EXIT;

FindCursor(X, Y, Top, Bottom);
OffCursor;
ShowInfoBox;
(*
** Install Hooks For the display Routines, Abort handler
*)

dbool := SetFnHook(CurrConfig.ComPort, ShowFile);
dbool := SetUserHook(CurrConfig.ComPort, ShowXferData);
dbool := SetAbortHook(CurrConfig.ComPort, ChkKbd);
dbool := LctYMSend(CurrConfig.ComPort, Path);

RmWin;
OnCursor;
PosCursor(X, Y);
END (* Upl_YM *);

PROCEDURE Upl_XM;
VAR
dbool : BOOLEAN;

BEGIN
dbool := SetFnHook(CurrConfig.ComPort, ShowFile);
dbool := SetUserHook(CurrConfig.ComPort, ShowXferData);
dbool := SetAbortHook(CurrConfig.ComPort, ChkKbd);
UseYModem(CurrConfig.ComPort, FALSE);
XMBlkSize := 128;
Send_XM;
END (* Upl_XM *);

PROCEDURE Upl_XMB;
VAR
dbool : BOOLEAN;

BEGIN
dbool := SetFnHook(CurrConfig.ComPort, ShowFile);
dbool := SetUserHook(CurrConfig.ComPort, ShowXferData);
dbool := SetAbortHook(CurrConfig.ComPort, ChkKbd);
UseYModem(CurrConfig.ComPort, TRUE);
XMBlkSize := 1024;
Send_XM;
END (* Upl_XM *);

PROCEDURE SaveConfig;
BEGIN
Assign(CfgFile, 'LCDEMO.CFG');
{$I-}
Rewrite(CfgFile); (* (re)create the file *)
{$I+}
IF IOResult <> 0 THEN (* was the file found ? *)
EXIT;
CurrConfig.Changed := FALSE;
Write(CfgFile, CurrConfig); (* write the config file *)
Close(CfgFile);
END (* SaveConfig *);

PROCEDURE LoadConfig;
BEGIN

Assign(CfgFile, 'LCDEMO.CFG');
{$I-}
Reset(CfgFile); (* attempt to open *)
{$I+}
IF IOResult = 0 THEN (* was the file found ? *)
BEGIN
Read(CfgFile, CurrConfig); (* load the last config *)
Close(CfgFile);
EXIT;
END;
CurrConfig.Changed := FALSE;
SaveConfig; (* force file create *)
END (* LoadConfig *);

{$F+}
PROCEDURE Task_Caller(VAR TopicCode:INTEGER; VAR RetCode:BYTE);
VAR
XYZ : INTEGER;

BEGIN
CASE TopicCode OF
1 : BEGIN
LcInfo;
RetCode := ClearAll;
END;
2 : BEGIN
LcReg;
RetCode := ClearAll;
END;
10 : BEGIN
Downl_XM;
RetCode := ClearAll;
END;
12 : BEGIN
Downl_XM;
RetCode := ClearAll;
END;
13 : BEGIN
Downl_YM;
RetCode := ClearAll;
END;
20 : BEGIN
Upl_XM;
RetCode := ClearAll;
END;
22 : BEGIN
Upl_XMB;
RetCode := ClearAll;
END;
23 : BEGIN
Upl_YM;
RetCode := ClearAll;
END;
32 : BEGIN
IF HostMode THEN
Modify_Topic_Name(Opt_Menu, 3, 'Host Mode - OFF')
ELSE
Modify_Topic_Name(Opt_Menu, 3, 'Host Mode - ON');
HostMode := NOT HostMode;
RetCode := RefreshTopic;
END;
33 : BEGIN
IF LocalEcho THEN
Modify_Topic_Name(Opt_Menu,4,'Local Echo - OFF')
ELSE
Modify_Topic_Name(Opt_Menu,4,'Local Echo - ON');
LocalEcho := NOT LocalEcho;
RetCode := RefreshTopic;
END;
35 : BEGIN
SaveConfig;
RetCode := ClearCurrent;
END;
40..43 : BEGIN
ChangePort((TopicCode-40)+1);
RetCode := ClearCurrent;
END;
50..58 : BEGIN
SetPort(TopicCode);
RetCode := ClearCurrent;
END;
999 : BEGIN
RetCode := ClearAll;
ExitActive := TRUE;
END;
ELSE
RetCode := ClearCurrent; (* terminate the menus *)
END;
END;
{$F-}

PROCEDURE InitMenus;
BEGIN
Initialize_Menu(Main_Menu, 'LCDemo', 0, 0);
Initialize_Menu(Desk_Menu, 'Information', 0, 0);
Initialize_Menu(Dnl_Menu, 'File Download', 0, 0);
Initialize_Menu(Upl_Menu, 'File Upload', 0, 0);
Initialize_Menu(Opt_Menu, 'User Options', 0, 0);
Initialize_Menu(Port_Menu, 'Active Port', 0, 0);
Initialize_Menu(Set_Menu, 'Port Settings', 0, 0);
Initialize_Menu(Quit_Menu, 'Quit', 0, 0);

(*
** Build Main Menu Topics
*)
Add_Topic(Main_Menu, 'Information Alt-I', TRUE, AltI, 0, @Desk_Menu);
Add_Topic(Main_Menu, 'Download Alt-D', TRUE, AltD, 0, @Dnl_Menu);
Add_Topic(Main_Menu, 'Upload Alt-U', TRUE, AltU, 0, @Upl_Menu);
Add_Topic(Main_Menu, 'Options Alt-O', TRUE, AltO, 0, @Opt_Menu);
Add_Topic(Main_Menu, 'Quit Alt-Q', TRUE, AltQ, 0, @Quit_Menu);

(*
** Build Information Menu Topics
*)
Add_Topic(Desk_Menu, 'About LiteComm', TRUE, #0, 1, NIL);
Add_Topic(Desk_Menu, 'Registration', TRUE, #0, 2, NIL);

(*
** Build File Download Menu
*)
Add_Topic(Dnl_Menu, 'Xmodem', TRUE, #0, 10, NIL);
Add_Topic(Dnl_Menu, 'Xmodem-1K', TRUE, #0, 12, NIL);
Add_Topic(Dnl_Menu, 'Ymodem', TRUE, #0, 13, NIL);

(*
** Build File Upload Menu
*)
Add_Topic(Upl_Menu, 'Xmodem', TRUE, #0, 20, NIL);
Add_Topic(Upl_Menu, 'Xmodem-1K', TRUE, #0, 22, NIL);
Add_Topic(Upl_Menu, 'Ymodem', TRUE, #0, 23, NIL);

(*
** Build User Options Menu
*)
Add_Topic(Opt_Menu, 'Active Port', TRUE, #0, 0, @Port_Menu);
Add_Topic(Opt_Menu, 'Port Settings', TRUE, #0, 0, @Set_Menu);
Add_Topic(Opt_Menu, 'Host Mode - OFF', TRUE, #0, 32, NIL);
Add_Topic(Opt_Menu, 'Local Echo - OFF', TRUE, #0, 33, NIL);
Add_Topic(Opt_Menu, 'Restore', TRUE, #0, 34, NIL);
Add_Topic(Opt_Menu, 'Save', TRUE, #0, 35, NIL);

(*
** Build Port Menu
*)
Add_Topic(Port_Menu, 'COM1', TRUE, #0, 40, NIL);
Add_Topic(Port_Menu, 'COM2', TRUE, #0, 41, NIL);
Add_Topic(Port_Menu, 'COM3', TRUE, #0, 42, NIL);
Add_Topic(Port_Menu, 'COM4', TRUE, #0, 43, NIL);

(*
** Build Settings Menu
*)
Add_Topic(Set_Menu, '1200,N,8,1', TRUE, #0, 50, NIL);
Add_Topic(Set_Menu, '1200,E,8,1', TRUE, #0, 51, NIL);
Add_Topic(Set_Menu, '2400,N,8,1', TRUE, #0, 52, NIL);
Add_Topic(Set_Menu, '2400,E,8,1', TRUE, #0, 53, NIL);
Add_Topic(Set_Menu, '9600,N,8,1', TRUE, #0, 54, NIL);
Add_Topic(Set_Menu, '9600,E,8,1', TRUE, #0, 55, NIL);
Add_Topic(Set_Menu, '19200,N,8,1', TRUE, #0, 56, NIL);
Add_Topic(Set_Menu, '19200,E,8,1', TRUE, #0, 57, NIL);

(*
** Build Quit Menu
*)
Add_Topic(Quit_Menu, 'No', TRUE, #0, 998, NIL);
Add_Topic(Quit_Menu, 'Yes', TRUE, #0, 999, NIL);
Assign_Despatcher(Task_Caller);

END (* InitMenus *);

PROCEDURE InitSetup;
VAR
dbool : BOOLEAN;

BEGIN
Window(1, 1, 80, 24);
ClearText(1, 1, 80, 25, WHITE, BLACK); (* erase screen before starting *)
ClearLine(25, LightBlue, LightGray);
PlainWrite(65, 25, 'F10 FOR MENU');
HostMode := FALSE;
LocalEcho := FALSE;
ExitActive := FALSE;

WITH CurrConfig DO
BEGIN
ComPort := 2;
BaudRate := 2400;
Parity := 'N';
DataBits := 8;
StopBits := 1;
dbool := CommOpen(ComPort, BaudRate, Parity, DataBits, StopBits, 2048, 2048, TRUE)
END (* with *);
LoadConfig; (* load existing config *)
END;

PROCEDURE ShowConnectStatus;
VAR
X, Y, Top, Bottom : BYTE;
MStatus : BYTE;

BEGIN
WITH CurrConfig DO
BEGIN
MStatus := ModemStatus(ComPort);
IF (MStatus AND (DeltaRI OR DeltaDCD OR DeltaCTS OR DeltaDSR)) = $00 THEN
EXIT;
FindCursor(X, Y, Top, Bottom);
OffCursor;
IF (MStatus AND DCD) <> $00 THEN
PlainWrite(2, 25, 'DCD')
ELSE
PlainWrite(2, 25, ' ');
IF (MStatus AND CTS) <> $00 THEN
PlainWrite(6, 25, 'CTS')
ELSE
PlainWrite(6, 25, ' ');
IF (MStatus AND DSR) <> $00 THEN
PlainWrite(10, 25, 'DSR')
ELSE
PlainWrite(10, 25, ' ');
IF (MStatus AND RI) <> $00 THEN
PlainWrite(14, 25, 'RI ')
ELSE
PlainWrite(14, 25, ' ');
PosCursor(X, Y);
OnCursor;
END (* with *);
END (* ShowConnectStatus *);

PROCEDURE TermDisplay(Ch : Char);
BEGIN
Write(Ch);
END (* TermDisplay *);

PROCEDURE Terminal;
VAR
Ch : CHAR;
dbool : BOOLEAN;

BEGIN
GotoXY(1, 1);
WHILE NOT ExitActive DO
BEGIN
IF KeyPressed THEN
BEGIN
Ch := GetKey;
CASE Ch OF
F10 : Show_Nest(Main_Menu);
AltI : Show_Nest(Desk_Menu);
AltD : Show_Nest(Dnl_Menu);
AltU : Show_Nest(Upl_Menu);
AltO : Show_Nest(Opt_Menu);
AltQ : Show_Nest(Quit_Menu);
ELSE
dbool := LctPut(CurrConfig.ComPort, BYTE(Ch));
IF LocalEcho THEN
TermDisplay(Ch);
END (* case *);
END (* if *);
IF LctGet(CurrConfig.ComPort, BYTE(Ch)) THEN
BEGIN
TermDisplay(Ch);
IF HostMode THEN
dbool := LctPut(CurrConfig.ComPort, BYTE(Ch));
END;
ShowConnectStatus;
END (* while *);
END (* Terminal *);

BEGIN
InitMenus;
InitSetup;
ShowPortStatus;
Terminal;

ClearText(1, 1, 80, 25, LightGray, Black);
END.


  3 Responses to “Category : Pascal Source Code
Archive   : LTCOMM50.ZIP
Filename : LCDEMO.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/