Category : Pascal Source Code
Archive   : TBBS.ZIP
Filename : IO.INC

 
Output of file : IO.INC contained in archive : TBBS.ZIP
(* ------------------------------------------------------ IO.INC ----------------------------------------- *)
var
cancelled : boolean;
inbuffer : line;

function charin(withecho: boolean):char; forward;

procedure sendout(ch: char);

{Character output - bypasses word-wrap; also performs
"pause" and "abort" input character checks.}

var temp: char;
tctl: boolean;

begin
if not cancelled then begin
if inready then begin
temp := charin(noecho);
if (temp = pause) or (upcase(temp) = 'S') then begin
tctl := controls;
controls := true;
temp := charin(noecho);
controls := tctl;
end;
if (temp = abort) or (upcase(temp) = 'C') then cancelled := true;
end;
xmitchar(ch);
if (ch <> bl) and (ch <> bell) then write(ch);
if printon then write(lst, ch);
if (ch = cr) and (lf = null) then writeln;
end;
end;

procedure flushbuff;

var
outpointer: byte;

begin
if length(buffer) > lastspace then
for outpointer := lastspace + 1 to length(buffer) do
sendout(buffer[outpointer]);
lastspace := length(buffer);
end;

procedure resetbuff;

begin
bufpointer := 0;
lastspace := 0;
charcount := 0;
buffer := '';
end;

procedure charout(ch:char);

{Character output using word-wrap}

var
buffull : boolean;
temp : long;

begin
if caps then ch := upcase(ch);
if not (ch in [null..#31]) then charcount := succ(charcount);
if (ch = bs) and (charcount > 0) then charcount := charcount - 1;
buffer := buffer + ch;
bufpointer := length(buffer);
buffull := (charcount + 2 > width);
if buffull then begin
if (lastspace > 0)
then begin
buffer := copy(buffer, lastspace + 1, bufpointer - lastspace);
charcount := length(buffer);
lastspace := 0;
end {then}
else begin
flushbuff;
resetbuff;
end; {else}
sendout(cr);
sendout(lf);
end; {if}
if ch in [null..space] then flushbuff;
if (ch=cr) then resetbuff;
end;

procedure stringout(message:line);

var
charpos: integer;

begin
for charpos := 1 to length(message) do charout(message[charpos]);
end;

procedure haltprog;
{ use to stop program }
begin
dropRTS;
port[$3d8] := $29;
Halt;
end;

procedure haltDOS;
{ used to rename ctty file then exit program with modem still active }
var
cttyfile: file;
const
tctty = 'tctty.bat';

begin
port[$3d8] := $29;
assign(cttyfile, 'tctty.bax');
{$I-} rename(cttyfile, tctty) {$I+};
Halt;
end;

procedure lineout; (* "forward" declared in MACHDEP *)

begin
stringout(message);
charout(cr);
charout(lf);
end;


function timedin: boolean;
{returns false if no character received in within
one second: used for XMODEM and input timeout.}
var times: integer;

begin
times := 0;
while (times < 500) and not inready do begin
times := times + 1;
delay(2);
end;
timedin := inready and cts;
end;

function charin;
var
ch: char;
countime: integer;
funckey : boolean;

begin
funckey := false;
dispinfo;
ch := null;
countime := 0;
repeat
if timedin then ch := recvchar else countime := countime + 1;
if keypressed then read(kbd, ch);
if keypressed and (ch = esc) then begin
read(kbd, ch);
funckey := true;
end;
{ toggle printer off/on }
if funckey and (ch = f2) then begin
printon := NOT printon;
ch := null;
dispinfo;
end;
{ toggle sysop in/out }
if funckey and (ch = f3) then begin
sysopin := not sysopin;
ch := null;
dispinfo;
end;
{ toggle screen off/on }
if funckey and (ch = f4) then begin
screenon := not screenon;
ch := null;
dispinfo;
end;
{ force current user off }
if funckey and (ch = f5) then begin
maxtime := 0;
ch := null;
dispinfo;
end;
{ shut down the system and exit to DOS }
if funckey and (ch = f9) then haltDOS;
{ shut down the system }
if funckey and (ch = f10) then haltprog;
if countime > maxidle then hangup;
if not cts then ch := cr;
if (ch <> bs) and not controls then ch := chr(ord(ch) and 127);
until (ch in [abort, pause, bs, tab, cr, space..#127])
or (controls and (ch <> null));
if (ch = #127) and not controls then ch := bs;
if ch = #$8D then ch := cr;
if withecho then begin
sendout(ch);
if ch = bs then begin sendout(' '); sendout(bs); end;
end;
charin := ch;
end;

function inputstring(withecho: boolean): line;

var
temp: line;
ch: char;

begin
temp := '';
flush;
repeat
ch := charin(noecho);
if (ch = bs) then begin
if length(temp) > 0 then begin
temp := copy(temp, 1, length(temp) - 1);
if withecho then begin
sendout(bs);
sendout(space);
sendout(bs);
end;
end;
end
else begin
if (ch <> cr) and (length(temp) < 80)
and ((ch in [tab, space..#126]) or controls) then begin
if ch = tab then repeat
temp := temp + space;
if withecho then sendout(space);
until (length(temp) mod 8) = 0
else begin
temp := temp + ch;
if withecho then sendout(ch);
end; {else}
end
else if (ch <> cr) then sendout(bell);
end;
until (ch = cr);
charout(cr); charout(lf);
inputstring := temp;
end;

function getinput(prompt:line; maxlength:integer; withecho:boolean):line;

var posn: integer;
temp: char;

begin
if cancelled then begin
cancelled := false;
lineout(space);
end;
if inbuffer = '' then begin
repeat
cancelled := false;
stringout(prompt);
if bl = bell then stringout(bl);
until cancelled = false;
inbuffer := inputstring(withecho);
end;
if maxlength = 1 then begin
if inbuffer = '' then temp := cr else begin
temp := inbuffer[1];
inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
if (length(inbuffer) > 1) and (inbuffer[1] = ';')
then inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
end; {else}
getinput := temp;
end
else begin
posn := pos(';', inbuffer);
if posn = 0 then posn := length(inbuffer) + 1;
if posn > maxlength then begin
posn := maxlength + 1;
inbuffer := copy(inbuffer, 1, maxlength);
end;
getinput := copy(inbuffer, 1, posn - 1);
if posn >= length(inbuffer)
then inbuffer := ''
else inbuffer := copy(inbuffer, posn + 1, length(inbuffer) - posn);
end;
end;

function allcaps(letters: person): person;

var
loop: byte;
temp: person;

begin
temp := '';
for loop := 1 to length(letters) do
temp := temp + upcase(letters[loop]);
allcaps := temp;
end;

procedure clearsc;

begin
stringout(cs);
delay(500); {allows time for slow terminal screen clears}
end;

procedure awaitcall;

var
junk: char;
sf : boolean;

begin
clrscr;
sf := true;
clock(month, date, hour, min, sec);
usehour := hour;
usemin := min;
usesec := sec;
caller := 'System Available';
dispinfo;
setbaud(fast);
writeln(cr + lf + 'Waiting for call...');
flush;
repeat
if keypressed then begin
read(kbd, junk);
local := junk = space;
if junk = f2 then begin
printon := NOT printon;
junk := null;
dispinfo;
end;
if junk = f3 then begin
sysopin := not sysopin;
dispinfo;
junk := null;
end;
if junk = f4 then begin
screenon := not screenon;
dispinfo;
junk := null;
end;
if junk = f5 then begin
maxtime := 0;
junk := null;
dispinfo;
end;
if junk = f9 then haltDOS;
if junk = f10 then haltprog;
if local then setlocal else exitchar := junk;
end;
until cts;
clrscr;
caller := '';
if not local then writeln('On Line...') else begin
writeln('Local control.');
screenon := true;
dispinfo;
end;
repeat
if sf then setbaud(fast) else setbaud(slow);
sf := not sf;
delay(400);
flush;
lineout('Press ENTER to continue');
junk := charin(noecho);
until (junk = cr) or not cts;
if baud = fast then lineout('1200 Baud') else lineout('300 Baud');
end;

function getcap(prompt: line): char;
begin
getcap := upcase(getinput(prompt, 1, echo));
end;

function getint(nmax, star: integer; prompt: line): integer;
var temp, test: integer;
outstr, userin: name;

begin
str(nmax:4, outstr);
repeat
temp := 0;
userin := getinput(prompt, 4, echo);
val(userin, temp, test);
if (temp > nmax) then lineout('Number too large: ' + outstr + ' maximum.');
until ((test = 0) and (temp >= 0) and (temp <= nmax))
or (userin = '*') or (userin = '') or (userin = '?') or not cts;
if userin = '?' then getint := -1
else if userin = '*' then getint := star
else if test = 0 then getint := temp
else getint := 0;
end;

{Real-time clock support starts here...
these routines must remain, even if there's
no clock! To kill clock support, simply set
"clockin" in BBS.PAS to false.}

type monthname = string[3];
monames = array[1..12] of monthname;

const months: monames = ('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');



function time(month, date, hour, min, sec: byte): name;

{Returns 14-character string containing time and date}

var
temps,
tempm,
tempd,
temph: string[2];

begin
if clockin then begin
str(sec:2,temps);
str(min:2,tempm);
str(hour:2,temph);
str(date:2,tempd);
if sec < 10 then temps := '0' + temps[2];
if min < 10 then tempm := '0' + tempm[2];
if date < 10 then tempd := '0' + tempd[2];
time := temph + ':' + tempm + ':' + temps + ' ' + months[month] + tempd;
end
else time := '';
end;

procedure lineout_withpause;
var
ch: char;

begin
if not cancelled then begin
stringout(message);
charout(cr);
charout(lf);
linecnt := linecnt + 1;
if (linecnt > 23) or ((linecnt > 22) and local) then begin
ch := getcap('Continue (/N/C) ? ');
linecnt := 0;
if (ch = 'N') then cancelled := true;
if (ch = 'C') then linecnt := linecnt - 10000;
end;
end;
end;

procedure showtime;
var
message: name;

begin
if clockin then begin
clock(month, date, hour, min, sec);
message := time(month, date, hour, min, sec);
lineout('Time is: ' + message);
end;
end;

procedure calcconnect(var usehour, usemin, usesec: integer);
var
xhour, xmin, xsec, xtime: integer;

begin
clock(month, date, hour, min, sec);
usemin := 0;
usehour := 0;

usesec := sec - onsec;
if usesec < 0 then begin
usesec := usesec + 60;
usemin := -1;
end;
usemin := min - onmin + usemin;
if usemin < 0 then begin
usemin := usemin + 60;
usehour := -1;
end;
usehour := hour - onhour + usehour;
if usehour < 0 then usehour := usehour + 24;
xtime := usesec + (usemin * 60) + (usehour * 3600) + tottimeonx;
usehour := xtime div 3600;
xtime := xtime - (usehour * 3600);
usemin := xtime div 60;
usesec := xtime - (usemin * 60);
end;

procedure connecttime;
var
message: name;

begin
if clockin then begin
calcconnect(usehour, usemin, usesec);
message := copy(time(1, 1, usehour, usemin, usesec), 1, 8);
lineout('Connect time: ' + message);
end;
end;


procedure searchlib(infile: name; var result, libsects: integer);
{Library-file support adapted from DELIB.PAS
by Bela Lubkin of Borland International.}

var
temp: name;
dirlength, offset, firstsec, loop, chrpos: integer;

begin
firstsec := 0; libsects := 0;
blockread(libfile, libbuff, 1);
if libbuff[0] <> 0 then result := 1;
loop := 1;
while (result = 0) and (loop <= 11) do begin
if libbuff[loop] <> 32 then result := 1;
loop := loop + 1;
end;
result := result + libbuff[12] + libbuff[13];
if result = 0 then begin
dirlength := libbuff[14] + 256*libbuff[15];
if dirlength = 0 then result := 1;
end;
if result = 0 then begin
loop := 0;
while (loop < 4*dirlength-1) and (result = 0) and (firstsec = 0) do begin
loop := loop + 1;
offset := 32*(loop mod 4);
if offset = 0 then blockread(libfile, libbuff, 1);
if libbuff[offset] <> 0 then result := 1
else begin
temp := '';
for chrpos := 1 to 8 do
if libbuff[offset + chrpos] <> 32 then
temp := temp + chr(libbuff[offset + chrpos]);
if libbuff[offset + 9] <> 32 then begin
temp := temp + '.';
for chrpos := 9 to 11 do
if libbuff[offset + chrpos] <> 32 then
temp := temp + chr(libbuff[offset + chrpos]);
end;
if cts and (infile = 'DIR') then lineout(temp);
if infile = temp then begin
firstsec := libbuff[offset+12] + 256*libbuff[offset+13];
libsects := libbuff[offset+14] + 256*libbuff[offset+15];
seek(libfile, firstsec);
end;
end;
end;
if infile = 'DIR' then result := 0;
end;
end;

procedure libassign(filename: longname; var result: integer);

var
infile: name;
slash: integer;
library: boolean;

begin
result := 0;
slash := pos('/', filename);
library := (slash > 0);
if library then begin
infile := copy(filename, slash + 1, length(filename) - slash);
filename := copy(filename, 1, slash - 1);
if pos('.', filename) = 0 then filename := filename + '.LBR';
end;
assign(libfile, filename);
{$I-} reset(libfile) {$I+};
result := IOresult;
if result = 0 then
if library then searchlib(infile, result, libsects)
else libsects := filesize(libfile);
libeof := (libsects = 0);
end;

procedure libblockread(var fileblock: filbuffer);

begin
if libsects > 0 then blockread(libfile, fileblock, 1);
libsects := libsects - 1;
if libsects = 0 then libeof := true;
end;

procedure typefile(fname: longname; nowrap: boolean);

{Inline unsqueezer adapted from USQ.PAS V1.3, which
was written by Scott Loftesness, adapted for Turbo
Pascal by Steve Freeman and made compatible with
Non-Turbo Pascal squeezers by myself.- BM}

const
recognize = $FF76;
numvals = 257; { max tree size + 1 }
speof = 256; { special end of file marker }
dle: char = #$90;

type
tree = array [0..255,0..1] of integer;

var
in_ptr, result: integer;
in_buff: filbuffer;
dnode: tree;
inchar, curin, filecksum, bpos, i, repct, numnodes: integer;
c, lastchar: char;
origfile: name;
squeezed, eofin: boolean;

function getc: integer;

begin
in_ptr := in_ptr + 1;
if in_ptr > 127 then begin
if libeof then eofin := true
else begin
libblockread(in_buff);
in_ptr := 0;
end;
end;
if eofin then getc := 26 else getc := in_buff[in_ptr];
end;

function getw: integer;

var in1,in2: integer;

begin
in1 := getc; in2 := getc;
getw := in1 + in2 shl 8;
end;

procedure initialize;

var str: string[14];

begin
in_ptr := 127; squeezed := true;
repct:=0; bpos:=99; origfile:=''; eofin:=false;
i := getw;
if (recognize <> i) then begin
squeezed := false;
in_ptr := -1;
end
else begin
filecksum := getw; { get checksum from chars 2 - 3 of file }
repeat { build original file name }
inchar:=getc;
if inchar <> 0
then origfile := origfile + chr(inchar);
until inchar = 0;
lineout('Original file: ' + origfile);
numnodes:=ord(getw); { get the number of nodes in this files tree }
if (numnodes<0) or (numnodes>=numvals) then begin
squeezed := false;
in_ptr := -1;
end;
end;
if squeezed then begin
dnode[0,0]:= -(speof+1);
dnode[0,1]:= -(speof+1);
numnodes:=numnodes-1;
for i:=0 to numnodes do begin
dnode[i,0]:=getw;
dnode[i,1]:=getw;
end;
end;
end;

function getuhuff: char;

var i: integer;

begin
i:=0;
repeat
bpos:=bpos+1;
if bpos>7 then begin
curin := getc;
bpos:=0;
end
else curin := curin shr 1;
i := ord(dnode[i,ord(curin and $0001)]);
until (i<0);
i := -(i+1);
if i=speof then begin
eofin:=true;
getuhuff:=chr(26);
end
else getuhuff:=chr(i);
end;

function getcr: char;

var c: char;

begin
if squeezed then begin
if (repct>0) then begin
repct:=repct-1;
getcr:=lastchar;
end
else begin
c:=getuhuff;
if c<>dle then begin
getcr:=c;
lastchar:=c;
end
else begin
repct:=ord(getuhuff);
if repct=0 then getcr:=dle
else begin
repct:=repct-2;
getcr:=lastchar;
end;
end;
end;
end
else getcr := chr(getc);
end; {getcr}

var
ch: char;

begin
linecnt := 0;
libassign(fname, result);
if result <> 0 then lineout('Can''t find ' + fname + '!')
else begin
initialize;
while cts and not(cancelled or eofin) do begin
c:=getcr;
if c = #26 then eofin := true else begin
if nowrap then begin
if c = #$8d then linecnt := linecnt + 1;
if c <> #$8D then begin { <-- Allows no-wrap using wordstar files}
c := chr(ord(c) and 127);
if (c <> lnfd) then charout(c);
if c = cr then charout(lf);
end;
end else begin
sendout(c);
end;

if c = cr then linecnt := linecnt + 1;
if (linecnt > 22) or ((linecnt > 21) and local) then begin
ch := getcap(lf + 'Continue (/N/C) ? ');
linecnt := 0;
if (ch = 'N') then cancelled := true;
if (ch = 'C') then linecnt := linecnt - 10000;
end;

end;
end;
close(libfile);
end;
end;

procedure outfile(fname: longname);

begin
typefile(fname, true);
end;

function findid(caller: person): integer;

var
usernum: integer;
index: integer;

begin
usernum := 0;
index := 0;
lineout('Searching userlist...');
{$I-} reset(idfile) {$I+};
if IOresult <> 0 then rewrite(idfile);
while (usernum = 0) and not eof(idfile) do begin
index := index + 1;
read(idfile, idrec);
if idrec.user = caller then usernum := index;
if (caller = '***') and (idrec.acc = 0) then usernum := index;
end;
findid := usernum;
end;

procedure getcomments(maxline: integer);

var
comfile: file of line;
linenum: integer;
head, temp: line;

begin
str(maxline:1, temp);
lineout('Enter comment: up to ' + temp + ' lines, enter empty line to quit.');
lineout(space);
linenum := 0;
assign(comfile, 'COMMENTS.BBS');
{$I-} reset(comfile) {$I+};
if IOresult <> 0 then rewrite(comfile);
seek(comfile, filesize(comfile));
head := caller;
if clockin then head := head + ' ' + timeon;
repeat
linenum := linenum + 1;
str(linenum:2, temp);
stringout(temp + ': ');
temp := inputstring(echo);
if temp <> '' then begin
if linenum = 1 then write(comfile, head);
write(comfile, temp);
end;
until (temp = '') or (linenum = maxline) or not cts;
close(comfile);
end;

function nextuser: integer;

var temp: integer;

begin
stringout('Finding space for new user: ');
temp := findid('***');
if temp = 0 then nextuser := 1 + filesize(idfile) else nextuser := temp;
end;

procedure savedefaults;

begin
calcconnect(usehour, usemin, usesec);
tottime := (usehour * 3600) + (usemin * 60) + usesec;
if usernum = 0 then usernum := nextuser;
with idrec do begin
user := caller;
if expert then exfl := 0 else exfl := 255;
if clockin then lsto := timeon;
lstm := nextmess-1;
pass := password;
clr := cs;
acc := access;
bsp := bs;
lnf := lf;
upc := caps;
wid := width;
tottimeon := tottime;
end;
seek(idfile, usernum - 1);
write(idfile, idrec);
end;

procedure disconnect;

var
ch: char;

begin
clearsc;
if (caller <> 'SYSOP') then begin
lineout('Answering question with other than "Y" or "N" returns to BBS:');
ch := getcap('Do you want to leave comments to the Sysop (Y/N)? ');
if ch = 'Y' then getcomments(15);
end else ch := 'N';
if (ch = 'N') or (ch = 'Y') or not cts then begin
connecttime;
lineout('Thanks for calling, ' + caller);
savedefaults;
hangup;
end;
end;


PROCEDURE checktime;

begin
calcconnect(usehour, usemin, usesec);
tottime := (usehour * 3600) + (usemin * 60) + usesec;
if clockin and (tottime > maxtime) then begin
lineout('Time limit exceeded for today...');
savedefaults;
hangup;
end;
dispinfo;
end;



  3 Responses to “Category : Pascal Source Code
Archive   : TBBS.ZIP
Filename : IO.INC

  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/