Category : Communication (modem) tools and utilities
Archive   : CAPTURE.ZIP
Filename : CAPTURE.PAS

 
Output of file : CAPTURE.PAS contained in archive : CAPTURE.ZIP
(* Generalized Multi-port SCOPE program *)
(*
Ver 1.0 - initial release
ver 2.0 - added file capture *)

{$M 32000,0,0}

program imsa;

uses dos,crt;

type str80 = string[80];
str50 = string[50];
str20 = string[20];
str40 = string[40];
str2 = string[2];
str200 = string[200];
str10 = string[10];
str6 = string[6];
str7 = string[7];
str250 = string[250];
str160 = string[160];

const com1 = $3f8; (* Communication port addresses *)
com2 = $2f8;
com3 = $3e8;
com4 = $2e8;
(* Display algorithms *)
cntr0 = $0040; (* 8253 CTC addresses *)
cntr1 = $0041;
cntr2 = $0042;
cntrm = $0043;

intr00 = $20; (* 8259 interrupt controller *)
intr01 = $21;
eoi = $20;

seoi0 = $60;
seoi1 = $61;
seoi2 = $62;
seoi3 = $63;
seoi4 = $64;
seoi5 = $65;
seoi6 = $66;
seoi7 = $67;

mask0 = $01;
mask1 = $02;
mask2 = $04;
mask3 = $08;
mask4 = $10;
mask5 = $20;
mask6 = $40;
mask7 = $80;

intr0 = 8;
intr1 = 9;
intr2 = 10;
intr3 = 11;
intr4 = 12;
intr5 = 13;
intr6 = 14;
intr7 = 15;

cmodl = $84; (* Counter mode register *)
cmode = $B4;
cmodx = $A4;

spkr = $0061; (* Speaker control port *)
spkrg = $01;
spkre = $02;

rs232data = $00; (* 8250 Serial Port offsets *)
intren = $01;
intrid = $02;
linectl = $03;
modctl = $04;
linstat = $05;
modstat = $06;
divlsb = $00;
divmsb = $01;

erbfi = $01; (* 8250 interrupt masks *)
etbei = $02;
elsi = $04;
edssi = $08;

dly = 300;

dtr = $01; (* Modem control bits *)
rts = $02;
outx = $0c;

dsr = $20; (* Modem status register bits *)
cts = $10;

rxready = $01;
overrun = $02;
parityerr = $04;
frameerr = $08;
breakintr = $10;
txempty = $20;
shiftempty = $40;

wlength0 = $01; (* Line control register *)
wlength1 = $02;
wlengthx = $03;
bits5 = $00;
bits6 = $01;
bits7 = $02;
bits8 = $03;
stopbits = $04;
parity = $08;
evenpar = $10;
forceon = $40;
dlatch = $80;

baud10 = 11520;
baud20 = 5760;
baud50 = 2304; (* Baud rate values *)
baud75 = 1536;
baud100 = 1152;
baud110 = 1047;
baud150 = 768;
baud300 = 384;
baud600 = 192;
baud1200 = 96;
baud1800 = 64;
baud2000 = 58;
baud2400 = 48;
baud3600 = 32;
baud4800 = 24;
baud7200 = 16;
baud9600 = 12;
baud19200 = 6;
baud38400 = 3;
baud56000 = 2;
baud115k = 1;

baudclk = 1843200;

warraysize = 101;

maxcommands = 100;

confidence = 100;

carret = #$0d;
linfeed = #$0a;
bspace = #$08;
escchar = #$1B;
controla = #$01;
eotchar = #$04;
etxchar = #$03;
stxchar = #$02;
ackchar = #$06;
nakchar = #$15;
rschar = #$1E;

timerclk = 1.19318;

residual = 6000;
procs = 3;

dogresettime = 1000;

scopesize = 1000;

type

processinfo = record (* Process state vector record *)
stack: word; (* Stack pointer *)
timeptr: word; (* Pointer to time vector *)
end; (* Process time vector *)
scopearray = array[0..scopesize] of byte;

comspec = record
portnumber: integer;
intr: pointer;
comaddr: word;
intrcom: integer;
seoicom: integer;
maskcom: integer;
baudcom: integer;
paritycom: integer;
stopscom: integer;
numbcom: integer;
filecom: string;
capturefile: file of byte;
sendflgcom: boolean;
inptr,outptr: integer;
scopebuffer: scopearray;
end;

var process: array[0..procs] of processinfo; (* Process vector *)
curproc: integer; (* Current active process *)

intrvectors: array[0..7] of pointer; (* Hardware intr vectors *)

comx: word;

s: str80;
c: char;

com1spec,com2spec,com3spec,com4spec: comspec;

rndnumb: word;

(* Save hardware interrupt vectors away for later restore *)

procedure saveintr;

var i,j,k: integer;

begin
for i := 0 to 7 do
getintvec(8+i,intrvectors[i]);
end;

(* Restore interrupt vectors *)

procedure restoreintr;

var i,j,k: integer;

begin
for i := 0 to 7 do
setintvec(8+i,intrvectors[i]);
end;

(* Given baud rate as argument, return DLATCH equivalent *)

function mapbaud(i: integer): integer;

begin
mapbaud := round(baudclk / 16.0) div i;
end;

(* Return true if something in receive buffer *)

function rxreadyp(com:word): boolean;

begin
if (port[com+linstat] and rxready) <> 0

then rxreadyp := true
else rxreadyp := false;
end;

(* Return true if transmit holding register empty *)

function txreadyp(com:word): boolean;

begin
if (port[com+linstat] and txempty) <> 0
then txreadyp := true
else txreadyp := false;
end;

(* Write modem setup information to com port *)

procedure writesetup(com:word; b:byte);

begin
port[com+linectl] := b;
end;

function readsetup(com:word): byte;

begin
readsetup := port[com+linectl];
end;

(* Assert/deassert RST to control IMSA reset *)

procedure assertrts;

begin
port[comx+modctl] := port[comx+modctl] or rts;
end;

procedure deassertrts;

begin
port[comx+modctl] := port[comx+modctl] and not(rts);
end;

(* Write baud rate divisor information to com port *)

procedure writebaud(com:word; w:word);

var b: byte;

begin
b := readsetup(com);
writesetup(com,b or dlatch);
port[com+divlsb] := w and $0ff;
port[com+divmsb] := (w and $0ff00) shr 8;
writesetup(com,b);
end;

(* Convert day, hour, minute into pure minute equivalent *)

function cvttomin(d,h,m: word): word;

begin
cvttomin := m + 60*(h + 24*(d-1));
end;

(* Declare tasks forward referenced *)

procedure switch; forward;

(* Procedures to return stack pointer & stack segment *)

function getsp: word;

inline ($8b/$c4);

procedure setsp(i:word);

inline ($5A/ {pop I}
$8B/$E0); {mov sp,ax}

function getbp: word;

inline ($8B/$C5);

procedure setbp(i:word);

inline ($5A/
$8B/$E8);

procedure setbpsp(i,j:word);

inline ($5A/ {Pop I}
$8B/$E5/ {mov bp,ax}
$5A/ {pop J}
$8B/$E0); {mov sp,ax}

(* Control interrupts *)

procedure disableintr;

inline($fa);

procedure enableintr;

inline($fb);

(* Convert nibble to hex ascii equivalent *)

function cvthex1(b: byte): char;

begin
case (b and $0f) of
0..9: cvthex1 := chr((b and $0f)+ord('0'));
else
cvthex1 := chr((b and $0f) - 10 + ord('A'));
end;
end;

(* Given byte argument - return 2 character hex ascii equivalent *)

function cvthex(b: byte): str2;

begin
cvthex := cvthex1(b shr 4) + cvthex1(b);
end;

(* Get next character from specified scope array *)

procedure getscope(var tmp: comspec);

var b: byte;

begin
with tmp do
if inptr = outptr
then switch
else
begin
if wherex <= 5 then clreol;
b := scopebuffer[outptr];
inc(outptr);
if outptr > scopesize then outptr := 0;
if filecom <> '' then write(capturefile,b);
if (b >= $20) and (b <= $7f)
then write(chr(b))
else write('{',cvthex(b),'}');
end;
end;

(* Conditionally open/close capture files *)

procedure closefile(var tmp: comspec);

begin
with tmp do
if filecom <> '' then close(capturefile);
end;

(* Open file *)

procedure openfile(var tmp: comspec);

begin
with tmp do
if filecom <> '' then
begin
assign(capturefile,filecom);
rewrite(capturefile);
end;
end;

(* Task: get characters from ports *)

procedure task0;

var i,j,k: integer;
c: char;
s: str80;
x,y: word;
x1,y1,x2,y2,x3,y3,x4,y4: integer;

const com1srt = 3;
com1end = 5;
com2srt = 9;
com2end = 11;
com3srt = 15;
com3end = 17;
com4srt = 21;
com4end = 23;

begin
switch;
clrscr;
x1 := 1; y1 := com1srt;
x2 := 1; y2 := com2srt;
x3 := 1; y3 := com3srt;
x4 := 1; y4 := com4srt;
gotoxy(1,com1srt-2);
writeln('COM 1 Data: ');
gotoxy(1,com2srt-2);
writeln('COM 2 Data: ');
gotoxy(1,com3srt-2);
writeln('COM 3 Data: ');
gotoxy(1,com4srt-2);
writeln('COM 4 Data: ');
openfile(com1spec);
openfile(com2spec);
openfile(com3spec);
openfile(com4spec);
repeat
gotoxy(x1,y1);
getscope(com1spec);
x1 := wherex; y1 := wherey;
if y1 > com1end then
begin
clreol;
y1 := com1srt;
end;
gotoxy(x2,y2);
getscope(com2spec);
x2 := wherex; y2 := wherey;
if y2 > com2end then
begin
clreol;
y2 := com2srt;
end;
gotoxy(x3,y3);
getscope(com3spec);
x3 := wherex; y3 := wherey;
if y3 > com3end then
begin
clreol;
y3 := com3srt;
end;
gotoxy(x4,y4);
getscope(com4spec);
x4 := wherex; y4 := wherey;
if y4 > com4end then
begin
clreol;
y4 := com4srt;
end;
until keypressed;
restoreintr;
closefile(com1spec);
closefile(com2spec);
closefile(com3spec);
closefile(com4spec);
halt;
end;

(* Generate next random byte *)

function random: byte;

begin
if rndnumb = 0 then rndnumb := 1;
if (rndnumb and $8000) = 0
then rndnumb := rndnumb shl 1
else
begin
rndnumb := rndnumb shl 1;
rndnumb := rndnumb xor $5391
end;
random := rndnumb and $ff;
end;

(* Task - send characters to ports *)

procedure task1;

var i,j,k: integer;
c: char;
z: str250;

begin
switch;
repeat
switch;
if txreadyp(com1) then
if com1spec.sendflgcom then port[com1 + rs232data] := random;
switch;
if txreadyp(com2) then
if com2spec.sendflgcom then port[com2 + rs232data] := random;
switch;
if txreadyp(com3) then
if com3spec.sendflgcom then port[com3 + rs232data] := random;
switch;
if txreadyp(com4) then
if com4spec.sendflgcom then port[com4 + rs232data] := random;
switch;
until false;
end;

(* Task 2 *)

procedure task2;

var i,j,k: integer;

begin
switch;
repeat
switch;
until false;
end;

(* Activate next process *)

procedure switch;

var i,j: word;

begin
i := getbp;
process[curproc].stack := i;
curproc := (curproc + 1) mod procs;
j := process[curproc].stack;
if j = 0 then
begin
i := getbp;
j := getsp;
i := i - residual;
j := j - residual;
setbpsp(i,j);
case curproc of
0: task0;
1: task1;
2: task2;
end;
end;
setbp(i);
end;


(* data receive interrupt - com port 1 *)

procedure scopeintr1(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word);

interrupt;

var i,j,k: integer;
b: byte;

begin
with com1spec do
begin
b := port[comaddr+rs232data];
scopebuffer[inptr] := b;
inc(inptr);
if inptr > scopesize then inptr := 0;
b := port[comaddr+modstat];
port[intr00] := eoi;
end;
end;

(* data receive interrupt - com port 2 *)

procedure scopeintr2(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word);

interrupt;

var i,j,k: integer;
b: byte;

begin
with com2spec do
begin
b := port[comaddr+rs232data];
scopebuffer[inptr] := b;
inc(inptr);
if inptr > scopesize then inptr := 0;
b := port[comaddr+modstat];
port[intr00] := eoi;
end;
end;

(* data receive interrupt - com port 3 *)

procedure scopeintr3(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word);

interrupt;

var i,j,k: integer;
b: byte;

begin
with com3spec do
begin
b := port[comaddr+rs232data];
scopebuffer[inptr] := b;
inc(inptr);
if inptr > scopesize then inptr := 0;
b := port[comaddr+modstat];
port[intr00] := eoi;
end;
end;

(* data receive interrupt - com port 4 *)

procedure scopeintr4(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word);

interrupt;

var i,j,k: integer;
b: byte;

begin
with com4spec do
begin
b := port[comaddr+rs232data];
scopebuffer[inptr] := b;
inc(inptr);
if inptr > scopesize then inptr := 0;
b := port[comaddr+modstat];
port[intr00] := eoi;
end;
end;

(* Set up communication port with specified parameters *)

procedure portsetup(com: comspec);

var b: byte;
async: byte;

begin
with com do
begin
async := stopscom + paritycom + numbcom;
setintvec(intrcom,intr);
writebaud(comaddr,baudcom);
writesetup(comaddr,async);
port[intr01] := port[intr01] or maskcom;
port[comaddr+intren] := erbfi;
port[comaddr+modctl] := port[comaddr+modctl] or (outx + dtr);
b := port[comaddr+rs232data];
b := port[comaddr+linstat];
port[intr01] := port[intr01] and not(maskcom);
port[intr00] := seoicom;
end;
end;

(* Initialize ALL data used by this program !!! *)

procedure initall;

var i,j,k: integer;

begin
for i := 0 to procs-1 do process[i].stack := 0;

with com1spec do
begin
portnumber := 1;
intr := @scopeintr1;
comaddr := com1;
intrcom := intr4;
maskcom := mask4;
seoicom := seoi4;
baudcom := baud2400;
paritycom := 0;
stopscom := 0;
numbcom := bits8;
filecom := '';
sendflgcom := false;
inptr := 0;
outptr := 0;
end;

with com2spec do
begin
portnumber := 2;
intr := @scopeintr2;
comaddr := com2;
intrcom := intr3;
maskcom := mask3;
seoicom := seoi3;
baudcom := baud2400;
paritycom := 0;
stopscom := 0;
numbcom := bits8;
filecom := '';
sendflgcom := false;
inptr := 0;
outptr := 0;
end;

with com3spec do
begin
portnumber := 3;
intr := @scopeintr3;
comaddr := com3;
intrcom := intr2;
maskcom := mask2;
seoicom := seoi2;
baudcom := baud2400;
paritycom := 0;
stopscom := 0;
numbcom := bits8;
filecom := '';
sendflgcom := false;
inptr := 0;
outptr := 0;
end;

with com4spec do
begin
portnumber := 4;
intr := @scopeintr4;
comaddr := com4;
intrcom := intr6;
maskcom := mask6;
seoicom := seoi6;
baudcom := baud2400;
paritycom := 0;
stopscom := 0;
numbcom := bits8;
filecom := '';
sendflgcom := false;
inptr := 0;
outptr := 0;
end;

end;

(* If specified file does not exist, create a null file *)

procedure makefile(s:str80);

var f: text;

begin
if fsearch(s,'.') = ''
then
begin
assign(f,s);
rewrite(f);
close(f);
end;
end;

(* Display baud rate string *)

procedure displaybaud(r: longint);

begin
r := baudclk div r;
r := r div 16;
write(r:6);
end;

(* Display parity *)

procedure displayparity(b: byte);

begin
if (b and parity) = 0
then write('NONE')
else
if (b and evenpar) = 0
then write('ODD ')
else write('EVEN');
end;

(* Display number of stop bits *)

procedure displaystops(b: byte);

begin
if (b and stopbits) <> 0
then write('TWO')
else write('ONE');
end;

(* Display number of bits in data character *)

procedure displaynumb(b: byte);

begin
case b and wlengthx of
bits5: write('5');
bits6: write('6');
bits7: write('7');
bits8: write('8');
end;
end;

(* Display interrupt request level *)

procedure displayintr(i: integer);

var j: integer;

begin
case i of
intr0: j := 0;
intr1: j := 1;
intr2: j := 2;
intr3: j := 3;
intr4: j := 4;
intr5: j := 5;
intr6: j := 6;
intr7: j := 7;
end;
write(j);
end;

(* given com specification, display on screen *)

procedure displaycom(s: string; tmp: comspec);

begin
write(s,' ');
with tmp do
begin
displaybaud(baudcom);
write(' ');
displayparity(paritycom);
write(' ');
displaystops(stopscom);
write(' ');
displaynumb(numbcom);
write(' ');
displayintr(intrcom);
write(' ');
if sendflgcom then write('ON ') else write('OFF');
write(' ');
write(filecom);
end;
writeln;
end;

(* User prompts *)

function prompts(s,cur: string): string;

var q: string;

begin
write(s);
write(' (',cur,'): ');
readln(q);
if q = '' then prompts := cur
else prompts := q;
end;

function prompti(s:string; cur: longint): longint;

var q: string;
i,j: integer;

begin
write(s);
write(' (',cur,'): ');
readln(q);
if q = ''
then prompti := cur
else
begin
val(q,cur,j);
prompti := cur;
end;
end;


(* Change baud rate to internal form *)

function cvtbaud(i: integer): integer;

var baud: integer;

begin
case i of
10: baud := 11520;
20: baud := 5760;
50: baud := 2304; (* Baud rate values *)
75: baud := 1536;
100: baud := 1152;
110: baud := 1047;
150: baud := 768;
300: baud := 384;
600: baud := 192;
1200: baud := 96;
1800: baud := 64;
2000: baud := 58;
2400: baud := 48;
3600: baud := 32;
4800: baud := 24;
7200: baud := 16;
9600: baud := 12;
19200: baud := 6;
else
writeln('Warning: invalid baud rate entered!');
end;
cvtbaud := baud;
end;

(* Change COM parameters *)

procedure changecom(var tmp: comspec);

var c: char;

begin
with tmp do
begin
filecom := prompts('Enter capture file name - space for none',filecom);
if (length(filecom) <> 0) and (filecom[1] = ' ') then filecom := '';
baudcom := cvtbaud(prompti('Enter baud rate',(baudclk div baudcom) div 16));
write('Want to transmit random characters to this port (y/n)? ');
c := upcase(readkey);
if c <> carret
then writeln(c)
else writeln;
case c of
'Y': sendflgcom := true;
'N': sendflgcom := false;
end;
write('Enter new number of stop bits - return for no change (1/2): ');
c := upcase(readkey);
if c <> carret
then writeln(c)
else writeln;
case c of
'1': numbcom := 0;
'2': numbcom := stopbits;
end;
write('Enter new parity - return for no change (N/O/E): ');
c := upcase(readkey);
if c <> carret
then writeln(c)
else writeln;
case c of
'O': paritycom := parity;
'E': paritycom := parity + evenpar;
'N': paritycom := 0;
end;
write('Enter new number of bits/character - return for no change (5/6/7/8): ');
c := upcase(readkey);
if c <> carret
then writeln(c)
else writeln;
case c of
'5': numbcom := bits5;
'6': numbcom := bits6;
'7': numbcom := bits7;
'8': numbcom := bits8;
end;
end;
end;

(* Main program follows *)

begin
saveintr;
initall;
repeat
clrscr;
writeln('Technobox, Inc 4-Port serial card data line monitor');
writeln('Ver 2.0 (C) 1990,1991 Technobox, Inc. - All rights reserved');
writeln;
writeln('Current COM settings ');
writeln;
writeln(' COM# BAUD PARITY STOPS #BITS INTRLVL XMIT? CAPTURE FILE');
writeln;
displaycom(' COM1',com1spec);
displaycom(' COM2',com2spec);
displaycom(' COM3',com3spec);
displaycom(' COM4',com4spec);
writeln;
write('Enter COM port to change (1/2/3/4): ');
c := readkey;
writeln(c);
case c of
'1': changecom(com1spec);
'2': changecom(com2spec);
'3': changecom(com3spec);
'4': changecom(com4spec);
else
c := 'N';
end;
until c = 'N';
portsetup(com1spec);
portsetup(com2spec);
portsetup(com3spec);
portsetup(com4spec);
clrscr;
curproc := 0;
task0;
end.

  3 Responses to “Category : Communication (modem) tools and utilities
Archive   : CAPTURE.ZIP
Filename : CAPTURE.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/