mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 00:14:25 +00:00
452 lines
11 KiB
ObjectPascal
452 lines
11 KiB
ObjectPascal
(*************************************************************************)
|
|
(* *)
|
|
(* SIMPLE MODEM v1.00 (c) Copyright S.J.Kay 18th April 1995 *)
|
|
(* Using the Ward Christensen file transfer protocol *)
|
|
(* *)
|
|
(* Uses CP/M 3.0 AUXIN and AUXOUT routines *)
|
|
(* *)
|
|
(*************************************************************************)
|
|
|
|
type
|
|
registers = record
|
|
case boolean of
|
|
true : (AL, AH, BL, BH, CL, CH, DL, DH : byte);
|
|
false : (AX, BX, CX, DX,
|
|
BP, SI, DI, DS, ES, FLAGS : integer)
|
|
end;
|
|
|
|
|
|
const
|
|
PthNme = '';
|
|
ENDBUF = $1FFF; { must be a multiple of 128 -1 }
|
|
|
|
SOH = $01; { Start Of Header }
|
|
EOT = $04; { End Of Transmission }
|
|
ACK = $06; { Acknowledge }
|
|
NAK = $15; { Negative Acknowledge }
|
|
CAN = $18; { Cancel }
|
|
|
|
|
|
var
|
|
R : registers;
|
|
F : file;
|
|
ExtCde : byte;
|
|
Check : byte;
|
|
BufPos : integer;
|
|
Abort : boolean;
|
|
TmeOut : boolean;
|
|
FleOpn : boolean;
|
|
Buffer : array [$0000..ENDBUF] of byte;
|
|
|
|
|
|
procedure ProcZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer);
|
|
begin
|
|
inline
|
|
(
|
|
$3A/Fn/ { ld a,(Fn) }
|
|
$32/* + 17/ { ld (FNCNMB),a }
|
|
$3A/Ax/ { ld a,(Ax) }
|
|
$ED/$4B/BCx/ { ld bc,(BCx) }
|
|
$ED/$5B/DEx/ { ld de,(DEx) }
|
|
$2A/HLx/ { ld hl,(HLx) }
|
|
$D3/$FF { out (FNCNMB),a }
|
|
)
|
|
end;
|
|
|
|
|
|
procedure Intr (Int : byte; var R : registers);
|
|
begin
|
|
ProcZ80($A1, Int, $AA55, $55AA, addr(R))
|
|
end;
|
|
|
|
|
|
function SerialOutputStatus : byte;
|
|
begin
|
|
SerialOutputStatus := bios(18) { test if AUXOUT is ready }
|
|
end;
|
|
|
|
function SerialInputStatus : byte;
|
|
begin
|
|
SerialInputStatus := bios(17) { test if AUXIN has a character }
|
|
end;
|
|
|
|
procedure SerialOutput (x : byte);
|
|
begin
|
|
bios(5, x);
|
|
end;
|
|
|
|
function SerialInput : byte;
|
|
begin
|
|
SerialInput := bios(6);
|
|
end;
|
|
|
|
|
|
function TickCount : integer;
|
|
begin
|
|
R.AH := $00;
|
|
intr($1A, R);
|
|
TickCount := R.DX
|
|
end;
|
|
|
|
|
|
procedure TestAbort;
|
|
var
|
|
Key : char;
|
|
begin
|
|
while keypressed do
|
|
begin
|
|
read(kbd, Key);
|
|
if (Key = ^[) or (Key = ^X) then
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 1
|
|
end
|
|
end
|
|
end;
|
|
|
|
|
|
procedure WriteByte (BytVal : byte; TckVal : integer);
|
|
var
|
|
BytOut : boolean;
|
|
T : integer;
|
|
begin
|
|
TmeOut := false;
|
|
if SerialOutputStatus <> 0 then
|
|
SerialOutput(BytVal)
|
|
else
|
|
begin
|
|
BytOut := false;
|
|
T := TickCount;
|
|
repeat
|
|
if SerialOutputStatus <> 0 then
|
|
begin
|
|
SerialOutput(BytVal);
|
|
BytOut := true
|
|
end
|
|
else
|
|
begin
|
|
TmeOut := (TickCount - T) >= TckVal;
|
|
if keypressed then
|
|
TestAbort
|
|
end
|
|
until BytOut or TmeOut or Abort
|
|
end
|
|
end;
|
|
|
|
|
|
function ReadByte (TckVal : integer) : byte;
|
|
var
|
|
BytInp : boolean;
|
|
T : integer;
|
|
begin
|
|
TmeOut := false;
|
|
if SerialInputStatus <> 0 then
|
|
ReadByte := SerialInput
|
|
else
|
|
begin
|
|
BytInp := false;
|
|
T := TickCount;
|
|
repeat
|
|
if SerialInputStatus <> 0 then
|
|
begin
|
|
ReadByte := SerialInput;
|
|
BytInp := true
|
|
end
|
|
else
|
|
begin
|
|
ReadByte := $FF;
|
|
TmeOut := (TickCount - T) >= TckVal;
|
|
if keypressed then
|
|
TestAbort
|
|
end
|
|
until BytInp or TmeOut or Abort
|
|
end
|
|
end;
|
|
|
|
|
|
procedure Purge;
|
|
var
|
|
Dummy : byte;
|
|
begin
|
|
repeat
|
|
Dummy := ReadByte(19) { 1 sec time out }
|
|
until TmeOut or Abort
|
|
end;
|
|
|
|
|
|
procedure SendCancel;
|
|
var
|
|
Dummy : byte;
|
|
begin
|
|
repeat
|
|
Abort := false;
|
|
Dummy := ReadByte(19) { 1 sec time out }
|
|
until TmeOut;
|
|
WriteByte(CAN, 91) { 5 sec time out }
|
|
end;
|
|
|
|
|
|
procedure StartNAK;
|
|
var
|
|
BytVal, Retry : byte;
|
|
begin
|
|
Retry := 15;
|
|
repeat
|
|
Purge; { 1 sec min time taken }
|
|
if not Abort then
|
|
begin
|
|
WriteByte(NAK, 1820); { 100 sec time out }
|
|
if TmeOut then
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 2
|
|
end;
|
|
if not Abort then
|
|
begin
|
|
BytVal := ReadByte(56); { 3 sec time out waiting ACK }
|
|
if Tmeout then
|
|
Retry := Retry - 1;
|
|
if Retry = 0 then
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 3
|
|
end
|
|
end
|
|
end
|
|
until (BytVal = ACK) or Abort
|
|
end;
|
|
|
|
|
|
procedure BlockNAK;
|
|
begin
|
|
Purge;
|
|
if not Abort then
|
|
begin
|
|
WriteByte(NAK, 1820); { 100 sec time out }
|
|
if TmeOut then
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 4
|
|
end
|
|
end
|
|
end;
|
|
|
|
|
|
procedure BlockACK;
|
|
begin
|
|
if not Abort then
|
|
begin
|
|
WriteByte(ACK, 1820); { 100 sec time out }
|
|
if TmeOut then
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 5
|
|
end
|
|
end
|
|
end;
|
|
|
|
|
|
procedure OpenFile;
|
|
var
|
|
i : integer;
|
|
FleNme : string[12];
|
|
begin
|
|
BufPos := 0;
|
|
FleNme := '';
|
|
i := 0;
|
|
while (i < 12) and (Buffer[i] <> 0) do
|
|
begin
|
|
FleNme := FleNme + chr(Buffer[i]);
|
|
i := i + 1
|
|
end;
|
|
gotoxy(42, 17);
|
|
write(FleNme, '':12);
|
|
assign(F, PthNme + FleNme);
|
|
rewrite(F);
|
|
FleOpn := true
|
|
end;
|
|
|
|
|
|
procedure FlushBuffer;
|
|
begin
|
|
blockwrite(F, Buffer, BufPos div 128);
|
|
BufPos := 0
|
|
end;
|
|
|
|
|
|
procedure CloseFile;
|
|
begin
|
|
if FleOpn then
|
|
begin
|
|
FlushBuffer;
|
|
close(F);
|
|
FleOpn := false
|
|
end
|
|
end;
|
|
|
|
|
|
function ReadBlockByte (TckVal : integer) : byte;
|
|
var
|
|
BytVal : byte;
|
|
begin
|
|
BytVal := ReadByte(TckVal);
|
|
Check := Check + BytVal;
|
|
ReadBlockByte := BytVal
|
|
end;
|
|
|
|
|
|
function CheckHeader : boolean;
|
|
var
|
|
BytVal : byte;
|
|
begin
|
|
BytVal := ReadBlockByte(182);
|
|
if (BytVal = EOT) and (not TmeOut) and (not Abort) then
|
|
begin
|
|
CloseFile;
|
|
WriteByte(ACK, 1820);
|
|
if TmeOut then
|
|
Abort := true;
|
|
if not Abort then
|
|
WriteByte(ACK, 1820);
|
|
if TmeOut then
|
|
Abort := true;
|
|
if Abort then
|
|
ExtCde := 6
|
|
end;
|
|
CheckHeader := BytVal = EOT
|
|
end;
|
|
|
|
|
|
procedure ReadBlocks;
|
|
var
|
|
Finish : boolean;
|
|
i, SveBuf : integer;
|
|
GetBlk, BlkNmb, BlkCpl, ChkSum : byte;
|
|
BytVal : byte;
|
|
begin
|
|
BufPos := 0;
|
|
GetBlk := 0;
|
|
FleOpn := false;
|
|
repeat
|
|
i := 0;
|
|
Check := 0;
|
|
SveBuf := BufPos;
|
|
Finish := CheckHeader;
|
|
if not Finish then
|
|
begin
|
|
if (not TmeOut) and (not Abort) then
|
|
BlkNmb := ReadBlockByte(19);
|
|
if (not TmeOut) and (not Abort) then
|
|
BlkCpl := ReadBlockByte(19);
|
|
while (not TmeOut) and (not Abort) and (i < 128) do
|
|
begin
|
|
BytVal := ReadBlockByte(19);
|
|
Buffer[BufPos] := BytVal;
|
|
BufPos := BufPos + 1;
|
|
i := i + 1
|
|
end;
|
|
if (not TmeOut) and (not Abort) then
|
|
ChkSum := ReadByte(19);
|
|
if (not TmeOut) and (not Abort) then
|
|
if ChkSum = Check then
|
|
begin
|
|
if not FleOpn and (BlkNmb = 0) then
|
|
begin
|
|
OpenFile;
|
|
gotoxy(43, 18);
|
|
write(BlkNmb, '': 2);
|
|
BlockACK
|
|
end;
|
|
if BlkNmb = GetBlk then
|
|
begin
|
|
gotoxy(43, 18);
|
|
write(BlkNmb, '': 2);
|
|
GetBlk := GetBlk + 1;
|
|
if BufPos > ENDBUF then
|
|
FlushBuffer;
|
|
BlockACK
|
|
end
|
|
else
|
|
begin
|
|
BufPos := SveBuf;
|
|
if BlkNmb = (GetBlk - 1) then
|
|
BlockACK
|
|
else
|
|
begin
|
|
Abort := true;
|
|
ExtCde := 7
|
|
end
|
|
end
|
|
end;
|
|
if TmeOut or (Check <> ChkSum) then
|
|
begin
|
|
BlockNAK;
|
|
BufPos := SveBuf
|
|
end
|
|
end
|
|
until Abort or Finish
|
|
end;
|
|
|
|
|
|
procedure Receive;
|
|
var
|
|
Retry, Finish : boolean;
|
|
BytVal : byte;
|
|
begin
|
|
Abort := false;
|
|
Finish := false;
|
|
ExtCde := 0;
|
|
repeat
|
|
StartNAK; { send NAK, then wait for ACK }
|
|
if not Abort then
|
|
begin
|
|
Retry := true;
|
|
while Retry and not Abort do
|
|
begin
|
|
BytVal := ReadByte(19); { 1st letter of filename or EOT }
|
|
Retry := TmeOut;
|
|
if not Retry then
|
|
Finish := BytVal = EOT
|
|
else
|
|
BlockNAK
|
|
end;
|
|
if (not Finish) and (not Abort) then
|
|
ReadBlocks
|
|
end
|
|
until Finish or Abort;
|
|
if Abort then
|
|
SendCancel;
|
|
gotoxy(1, 23);
|
|
case ExtCde of
|
|
1 : writeln('User cancelled by pressing abort key');
|
|
2 : writeln('Unable to send initial NAK to sender');
|
|
3 : writeln('No ACK response for initial NAK sent');
|
|
4 : writeln('Unable to send NAK for bad block');
|
|
5 : writeln('Unable to send ACK for block received');
|
|
6 : writeln('Unable to send ACK for file end (EOT)');
|
|
7 : writeln('Fatal loss of sync receiving blocks')
|
|
end
|
|
end;
|
|
|
|
|
|
begin
|
|
clrscr;
|
|
writeln(' MODEM v1.00 (c) S.J.Kay 1st April 1995');
|
|
writeln;
|
|
writeln(' Uses the Ward Christensen file transfer protocol');
|
|
writeln(' with file name support.');
|
|
writeln;
|
|
writeln(' NOTE: Files will be written to the default drive.');
|
|
writeln;
|
|
writeln(' Uses AUXIN and AUXOUT devices, set device for correct values');
|
|
writeln(' before using this program');
|
|
writeln;
|
|
writeln(' To abort press the ESC or ^X keys at any time');
|
|
writeln;
|
|
gotoxy(31, 17);
|
|
write( 'Receiving:');
|
|
gotoxy(31, 18);
|
|
write( ' Block: #');
|
|
Receive
|
|
end.
|