Category : Pascal Source Code
Archive   : PROD30S2.ZIP
Filename : READBAS.INC

 
Output of file : READBAS.INC contained in archive : PROD30S2.ZIP

(*
* Copyright 1987, 1989 Samuel H. Smith; All rights reserved
*
* This is a component of the ProDoor System.
* Do not distribute modified versions without my permission.
* Do not remove or alter this notice or any other copyright notice.
* If you use this in your own program you must distribute source code.
* Do not use any of this in a commercial product.
*
*)

(*
* readbas.inc - Library to read "basic" format data files (3-1-89)
*
*)


procedure openfile(name: string65);
(* open a file for "basic" style parsing *)
begin
if length(name) = 0 then
begin
ok := false;
exit;
end;

assignText(curfd,name);
{$i-} reset(curfd); {$i+}
ok := ioresult = 0;

if ok then
begin
dos_getmem(readbas_buf,sizeof(readbas_buf^));
setTextBuf(curfd,readbas_buf^);
end;
end;


(* --------------------------------------------------------- *)
function endfile: boolean;
(* check for end of file on the current data file *)
begin
endfile := {seek}eof(curfd);
end;



(* --------------------------------------------------------- *)
procedure closefile;
(* close the data file *)
begin
close(curfd);
dos_freemem(readbas_buf);
end;


(* --------------------------------------------------------- *)
procedure getaline(var line: string;
len: integer);
(* get a full line from the "basic" file *)
var
buf: string;

begin
(**********
if endfile then
buf := ^Z
else
readln(curfd,buf);
**********)
qReadLn(curfd,buf,sizeof(buf));

line := copy(buf,1,len-1);
end;


(* --------------------------------------------------------- *)
procedure getline(var line: string;
len: integer);
(* get a full line from the "basic" file, skip comments *)
begin
repeat
getaline(line,len);
until (length(line) = 0) or (line[1] <> readbas_comment);
end;


(* --------------------------------------------------------- *)
procedure getstr(var str: string;
len: integer);
(* get a string of characters from the "basic" file. a string ends in
either "," or crlf *)
var
c: char;
label
comment;

begin
if endfile then
str := ^Z
else

begin
comment:
str := '';
if endfile then
c := #26
else
read(curfd,c);

while (c = ' ') do
read(curfd,c);

if c = readbas_comment then
begin
readln(curfd);
goto comment;
end;

while (c <> ',') and (c <> #13) and (c <> #26) do
begin
if length(str) < len then
inc(str[0]);
str[length(str)] := c;
read(curfd,c);
end;

if c = #13 then {consume linefeed}
read(curfd,c);
end;
end;


(* --------------------------------------------------------- *)
procedure skipstr;
(* skip over a , delimited string *)
var
buf: string10;
begin
getstr(buf,sizeof(buf)-1);
end;


(* --------------------------------------------------------- *)
procedure getstrd(var str: string);
(* get a directory string from the "basic" file. check special case
for no trailing "\" in the root directory *)
begin
getstr(str,65);
stoupper(str);

if str[length(str)] = '\' then
dec(str[0]); {remove trailing "\" from ramdisks and such}
end;


(* --------------------------------------------------------- *)
procedure getint(var i: integer);
(* get a string and convert it into an integer *)
var
buf: string10;
begin
getstr(buf,sizeof(buf)-1);
i := atoi(buf);
end;

procedure readint(var i: integer);
(* get a string and convert it into an integer *)
var
buf: string10;
e: integer;
begin
getaline(buf,sizeof(buf)-1);
val(buf,i,e);
end;


procedure readword(var i: word);
(* get a string and convert it into a word *)
var
buf: string10;
e: integer;
begin
getaline(buf,sizeof(buf)-1);
val(buf,i,e);
end;


(* --------------------------------------------------------- *)
procedure readflag(var f: boolean);
(* get a string and convert it into a true/false flag *)
var
buf: string;
begin
getaline(buf,sizeof(buf));
f := (buf[1] = '-') or (buf[1] = 'Y');
end;


(* --------------------------------------------------------- *)
procedure vgetstr(var str: varstring);
(* get a variable allocation string of characters from the "basic"
file. a string ends in either "," or crlf *)
var
temp: string;
begin
getstr(temp,sizeof(temp)-1);
savestr(str,temp);
end;


(* --------------------------------------------------------- *)
procedure vgetline(var str: varstring);
(* get a variable allocation string of characters from the "basic"
file. a string ends in either "," or crlf *)
var
temp: string;
begin
getaline(temp,sizeof(temp)-1);
savestr(str,temp);
end;


(* --------------------------------------------------------- *)
procedure vgetstrd(var str: varstring);
(* get a variable allocation string and format as a directory *)
var
temp: string65;
begin
getstr(temp,sizeof(temp)-1);
if (length(temp) > 2) and (temp[length(temp)] = '\') then
dec(temp[0]); {remove trailing "\" from ramdisks and such}
savestr(str,temp);
end;


(* --------------------------------------------------------- *)
procedure skipline;
begin
getline(par,sizeof(par)-1);
end;

procedure skiplines(n: integer); {skip(ignore) a number of lines, last in par}
begin
while n > 0 do
begin
skipline;
dec(n);
end;
end;




  3 Responses to “Category : Pascal Source Code
Archive   : PROD30S2.ZIP
Filename : READBAS.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/