home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdpecan.zip
/
kermutil.text
< prev
next >
Wrap
Text File
|
1990-08-05
|
18KB
|
597 lines
$D OS_ERHDL+} { indicates to compile to use Pecan's errorhandler unit
$D OS_TIMER+} { indicates to compile to use TIME() for timeouts
unit kermutil;
{ Change log:
13 May 89, V1.1: Eliminated "int_bool_rec" & misc cleanups RTC
30 Apr 89, V1.1: Moved set/show & connect from kermit to here RTC
26 Apr 89, V1.1: Added support for TIMEr controlled timeouts RTC
16 Apr 89, V1.1: Added procedure flush_comm to Flush REMOTE: RTC
13 Apr 89, V1.1: Added Version message RTC
17 Aug 88: Fixed missing EOLN's problem in debf RTC
14 Aug 88: Fixed the debug messages to all go to debf RTC
31 Jul 88: Modified setup_comm to funct., updated io_error. RTC
10 Jul 88: Converted to using screenops unit RTC
02 Jul 88: Misc cleanup, eliminated char_int_rec, etc. RTC
26 Jun 88 Patched Unitwrite problem in Echo RTC
26 Jun 88 Modified read_ch to use cr_getkb RTC
13 May 84: Use KERNEL's syscom record for screen control -sp-
}
$I intfutil.text
uses {$U *system.library} screenops, {RTC, 10 Jul 88}
{$U kermenus.code} kermenus,
{$U kermpack.code} kermpack (pak_version),
{$U helper.code} helper (hlp_version),
{$U parser.code} parser (par_version),
{$U sender.code} sender (sen_version),
{$U receiver.code} receiver (rec_version),
{$U client.code} client (cli_version),
{$U remunit.code} remunit, {SP, 1/14/84}
{$U syslibr:kernel.code} kernel (syscom,version) {$B OS_ERHDL+},
{$U syslibr:errorhandl.code} error_handling {$E OS_ERHDL+};
const
my_version = ' Kermutil Unit V1.1, 13 May 89';
type
time_value = integer[10];
var
old_flush, old_stop: char;
time_limit : time_value;
$I setshow.text
procedure connect;
(* connect to remote host and transceive *)
var ch: char;
close: boolean;
procedure read_esc;
(* read character after esc char and interpret it *)
begin
repeat
until read_ch(keyport,ch); (* wait until they've typed something in *)
if (ch in ['a'..'z']) then (* uppercase it *)
ch := chr(ord(ch) - ord('a') + ord('A'));
if ch in ['B','C','S','?'] then
case ch of
'B': sendbrk; (* B: send a break to the IBM *)
'C': close := true; (* C: end connection *)
'S': begin (* S: show status *)
noun := allsym;
showparms
end; (* S *)
'?': begin (* ?: show options *)
writeln
('B Send a BREAK signal.');
writeln
('C Close Connection, return to KERMIT-UCSD command level.');
writeln
('S Show Status of connection');
writeln
('? Print this list');
writeln
('^',ctl(esc_char),' send the escape character itself to the remote host.')
end; (* ? *)
end (* case *)
else if ch = esc_char then (* ESC-char: send it out *)
begin
if half_duplex then
write(ch); { changed from echo() by SP }
write_ch(oport,ch)
end (* else if *)
else (* anything else: ignore *)
write(chr(bell))
end; (* read_esc *)
begin (* connect *)
clear_buf(keyport); (* empty keyboard buffer *)
clear_buf(inport); (* empty remote input buffer *)
writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
close := false;
repeat
if read_ch(inport,ch) then (* if char from host then *)
echo(ch); (* echo it *)
if read_ch(keyport,ch) then (* if char from keyboard then *)
if ch <> esc_char then (* if not ESC-char then *)
begin
if half_duplex then (* echo it if half-duplex *)
write(ch); { changed from echo() by sp }
write_ch(oport,ch) (* send it out the port *)
end (* if *)
else (* ch = esc_char *) (* else is ESC-char so *)
read_esc; (* interpret next char *)
until close; (* if still connected, get more *)
writeln('Disconnected')
end; (* connect *)
procedure uppercase(*var s: string255*);
var i: integer;
begin
for i := 1 to length(s) do
if s[i] in ['a'..'z'] then
s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)
function read_ch(*unitno:integer; var ch: char): boolean*);
(* read a character from an input queue *)
var
ready: boolean;
begin
if unitno=keyport then
ready := cr_kbstat
else if unitno=inport then
ready := cr_remstat
else
ready := false;
if ready then (* if a char there *)
if unitno=keyport then
ch := cr_getkb
else
ch := cr_getrem;
read_ch := ready
end; (* read_ch *)
procedure write_ch(*unitno: integer; ch: char*);
begin
if unitno=oport then
cr_putrem( ch )
end;
procedure read_str(*unitno:integer; var s: string255*);
(* acts like readln(s) but takes input from input queue *)
var i: integer;
begin
i := 0;
s := copy('',0,0);
repeat
repeat (* get a character *)
until read_ch(unitno,ch);
if (ord(ch) = backspace) then (* if it's a backspace then *)
begin
if (i > 0) then (* if not at beginning of line *)
begin
write(ch); (* go back a space on screen *)
write(' '); (* erase char on screen *)
write(ch); (* go back a space again *)
i := i - 1; (* adjust string counter *)
s := copy(s,1,i) (* adjust string *)
end (* if *)
end (* if *)
else if (ord(ch) <> eoln_sym) then (* otherwise if not at eoln then *)
begin
write(ch); (* echo char on screen *)
i := i + 1; (* inc string counter *)
s := concat(s,' ');
s[i] := ch; (* put char in string *)
end; (* if *)
until (ord(ch) = eoln_sym); (* if not eoln, get another char *)
s := copy(s,1,i); (* correct string length *)
writeln (* write a line on the screen *)
end; (* read_str *)
procedure clear_buf(*unitno:integer*);
modified by SP
begin
if unitno=keyport then
unitclear( unitno )
end;
procedure send_brk;
begin
cr_break
end;
function setup_comm{ : boolean};
SP, 14 Jan 84
var
result: cr_baud_result;
begin
setup_comm := false;
cr_setcommunications(false,
false,
baud,
8,
1,
cr_orig,
system_id,
result );
case result of
CR_bad_parameter :
writeln('Bad Parameter, # Bits or Parity wrong');
CR_bad_rate :
writeln('Bad Baud Rate selection');
CR_set_OK :
setup_comm := true;
CR_select_not_supported :
writeln('Hardware does not support Baud selection')
end {case}
end;
procedure flush_comm; {added 16 Apr 89, RTC}
var
ch : char;
begin {flush_comm}
while CR_remstat do
ch := CR_getrem {flush all characters in REMOTE port}
end {flush_comm};
function aand(*x,y: integer): integer*);
(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)
begin
aand := ord(odd(x) and odd(y)); (* use as booleans to 'and' them *)
end; (* aand *)
function aor(*x,y: integer): integer*);
(* arithmetic or *)
begin
aor := ord(odd(x) or odd(y)); (* use as booleans to 'or' them *)
end; (* aor *)
function xor(*x,y: integer): integer*);
(* exclusive or *)
begin
xor := ord( (odd(x) or odd(y)) and not(odd(x) and odd(y)) );
end; (* xor *)
procedure error(*p: packettype; len: integer*);
(* writes error message sent by remote host *)
var i: integer;
begin
gotoxy(0,errorline);
for i := 0 to len-1 do
write(p[i]);
gotoxy(0,promptline);
end; (* error *)
procedure io_error(*i: integer*);
var
message : string;
begin
SC_erase_to_EOL( 0, errorline );
{$B OS_ERHDL+}
IOR_to_message(i,message);
{$E OS_ERHDL+} {$B OS_ERHDL-}
case i of
0: message := 'No error';
1: message := 'Bad Block, Parity error (CRC)';
2: message := 'Bad Unit Number';
3: message := 'Bad I/O request, Illegal operation';
4: message := 'Undefined hardware error';
5: message := 'Lost unit, Volume is no longer on-line';
6: message := 'Lost file, File is no longer in directory';
7: message := 'Bad Title, Illegal file name';
8: message := 'No room, insufficient space';
9: message := 'No unit, No such volume on line';
10: message := 'No file, No such file on volume';
11: message := 'Duplicate file';
12: message := 'Not closed, attempt to open an open file';
13: message := 'Not open, attempt to access a closed file';
14: message := 'Bad format, error in reading real or integer';
15: message := 'Queue overflow';
16: message := 'Write Protected volume';
17: message := 'Illegal Block';
18: message := 'Illegal Buffer for low-level I/O';
19: message := 'Illegal Size or Range of File Attribute';
20: message := 'Attempted read past End of File';
end; (* case *)
if i >= 128 then
begin
i := i - 128; message := '0';
while i > 0 do
begin
message[1] := chr(ord('0') + i mod 10);
message := concat(' ',message);
i := i div 10
end;
message := concat('Host Operating System Error #',message)
end;
{$E OS_ERHDL-}
writeln(message);
gotoxy(0,promptline)
end; (* io_error *)
procedure debugwrite(*s: string255*);
(* writes a debugging message *)
var i: integer;
begin
if debug then
begin
SC_erase_to_EOL(0,debugline);
gotoxy(0,pred(debugline)); writeln(debf);
write(debf,s);
for i := 1 to 2000 do ; (* write debugging message *)
end (* if debug *)
end; (* debugwrite *)
procedure debugint(*s: string255; i: integer*);
(* write a debugging message and an integer *)
begin
if debug then
begin
debugwrite(s);
write(debf,i)
end (* if debug *)
end; (* debugint *)
function min(*x,y: integer): integer*);
(* returns smaller of two integers *)
begin
if x < y then
min := x
else
min := y
end; (* min *)
function tochar(*ch: char): char*);
(* tochar converts a control character to a printable one by adding space *)
begin
tochar := chr(ord(ch) + ord(' '))
end; (* tochar *)
function unchar(*ch: char): char*);
(* unchar undoes tochar *)
begin
unchar := chr(ord(ch) - ord(' '))
end; (* unchar *)
function ctl(*ch: char): char*);
(* ctl toggles control bit: ^A becomes A, A becomes ^A *)
begin
ctl := chr(xor(ord(ch),64))
end; (* ctl *)
procedure echo(*ch: char*);
(* echos a character on the screen *)
var cursorx, cursory:integer;
ch_buf : packed array [0..1] of char;
The DataMedia emulation is by John Socha.
begin
ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
ch_buf[0] := ch; {for unitwrite portability RTC}
if emulating and (ord(ch) in [30,25,28,31,29,11]) then
case ord(ch) of
{ Datamedia 1520 emulation }
{ rs }30: begin
{ allow timeout while waiting for coordinates
so computer doesn't freeze }
set_timer(2);
repeat
until read_ch( inport, ch ) or timeout;
if not timeout then begin
cursorx:=ord(ch)-32;
repeat
until read_ch( inport, ch ) or timeout;
if not timeout then begin
cursory:=ord(ch)-32;
gotoxy(cursorx,cursory)
end
end
end;
{ em }25: SC_home;
{ fs }28: SC_right;
{ us }31: SC_up;
{ gs }29: SC_erase_to_EOL(SC_find_X,SC_find_Y);
{ vt }11: SC_eras_eos(SC_find_X,SC_find_Y)
end
else
unitwrite(1,ch_buf[0],1,,12) { the 12 eliminates DLE & CR expansion }
end; (* echo *)
function getch(*var r: char): boolean*);
(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after timeout *)
begin
getch := false;
repeat
until (read_ch(inport,r)) or timeout; (* wait for a character *)
if timeout then (* if wait too long then *)
exit(getch); (* get out of here *)
if parity <> nopar
then r := chr(aand(ord(r),127)); (* strip parity from char *)
getch := (r <> chr(soh)); (* return true if not SOH *)
end; (* getch *)
function getsoh(*: boolean*);
(* reads characters until it finds an SOH; returns false if has timed out *)
var ch: char;
begin
getsoh := true;
repeat
repeat
until (read_ch(inport,ch)) or timeout; (* wait for a character *)
if timeout then
begin
getsoh := false;
exit(getsoh)
end; (* if *)
ch := chr(aand(ord(ch),127)); (* strip parity of char *)
until (ch = chr(SOH)) (* if not SOH, get more *)
end; (* getsoh *)
function getfil(*filename: string255): boolean*);
(* opens a file for writing *)
begin
(*$I-*) (* turn i/o checking off *)
if f_is_binary
then
begin
rewrite(b_file,filename);
bufpos := 1 {new file... nothing in buffer}
end
else rewrite(t_file,filename);
(*$I-*) (* turn i/o checking on *)
getfil := (ioresult = 0)
end; (* getfil *)
procedure writescreen(*s: string255*);
(* sets up the screen for receiving or sending files *)
begin
page(output);
gotoxy(0,titleline);
write(' Kermit UCSD p-System, Version ', version );
gotoxy(statuspos,statusline);
write(s);
gotoxy(0,packetline);
write('Number of Packets: ');
gotoxy(0,retryline);
write('Number of Tries: ');
gotoxy(0,fileline);
write('File Name: ');
end; (* writescreen *)
procedure refresh_screen(*numtry, num: integer*);
(* keeps track of packet count on screen *)
begin
gotoxy(retrypos,retryline);
write(numtry: 5);
gotoxy(packetpos,packetline);
write(num: 5)
end; (* refresh_screen *)
$B OS_TIMER+
procedure long_time(var t : time_value);
{this procedure converts the "dual integer" values returned by time()
to a single "long integer" value, which it returns to the caller}
var
i : 0..1;
hl : array [0..1] of integer;
begin {long_time}
t := 0; time(hl[0],hl[1]);
for i := 0 to 1 do
begin
if hl[i] < 0 then t := t + 1;
t := 65536*t + hl[i]
end
end {long_time};
$E OS_TIMER+
procedure set_timer{t : integer}; {added 26 Apr 89, RTC}
{$B OS_TIMER-}
const counts_per_second = 1000; {WARNING!! implementation dependant}
{$E OS_TIMER-}
var long_t : time_value;
begin {set_timer}
long_t := t; {convert to long format}
{$B OS_TIMER+}
long_time(time_limit); time_limit := time_limit + 60*long_t
{$E OS_TIMER+} {$B OS_TIMER-}
time_limit := counts_per_second*long_t
{$E OS_TIMER-}
end {set_timer};
function timeout {: boolean}; {added 26 Apr 89, RTC}
{$B OS_TIMER+}
var this_time : time_value;
{$E OS_TIMER+}
begin {timeout}
{$B OS_TIMER+}
long_time(this_time);
timeout := this_time > time_limit
{$E OS_TIMER+} {$B OS_TIMER-}
time_limit := time_limit - 1;
timeout := time_limit <= 0
{$E OS_TIMER-}
end {timeout};
procedure utl_version;
begin
write(my_version);
{$B OS_TIMER+}
write(' (with TIMER)');
{$E OS_TIMER+}
writeln
end {utl_version};
begin { body of unit kermutil }
{ initialization code }
old_flush := syscom^.crtinfo.flush;
old_stop := syscom^.crtinfo.stop;
syscom^.crtinfo.flush := chr(255); { effectively turning flush off }
syscom^.crtinfo.stop := chr(254); { effectively turning stop off }
***;
{ termination code }
syscom^.crtinfo.flush := old_flush; { turn flush back on }
syscom^.crtinfo.stop := old_stop { turn stop back on }
end. { kermutil }