Oakland CPM Archive/oakcpm.iso/cpm/bbs/tpbbs10.ark/TPUT10.PAS

Pascal/Delphi Source File | 1986-09-14 | 11.5 KB | 609 lines

program TPUTIL {BBS system utility program};

const
  system='Osborne TurboPascal BBS';
  drive1='A:';{BYE.COM on this drive}
  drive2='A:';{text,BBS stat files on this drive}
  drive3='A:';{message system files on this drive}
  ext='';
  version='TurboPascal BBS v1.0  c1984';
  date1='Original 30 APR 1984';

label
  loop10,loop,done;

type
  AllStrings=string[128];
  tagline=string[10];
  msgline=string[65];
  username=string[25];
  citystate=string[15];
  password=string[10];
  date=string[8];
  pswd=string[10];
  about=string[25];
  nameto=string[25];
  datetime=string[18];

  userlist=record
      name:username;
      address:citystate;
      userpassword:password;
      lastmessage:integer;
      lastdate:datetime;
  end;

  stat_list=record
      msgs:integer;
      calls:integer;
      mstart:integer;
      mnum:integer;
  end;

  caller_list=record
      caller:username;
      cfrom:citystate;
      cdate:date;
      ctime:date;
  end;

  comment_list=record
      comment:msgline;
      end;

  summary_list=record
      msgnum:integer;
      person_from:username;
      person_to:nameto;
      subject:about;
      mdate:date;
      mpassword:pswd;
      no_of_lines:integer;
      prev_no_lines:integer;
  end;

  newsumm_list=record
      bmsgnum:integer;
      bperson_from:username;
      bperson_to:nameto;
      bsubject:about;
      bmdate:date;
      bmpassword:pswd;
      bno_of_lines:integer;
      bprev_no_lines:integer;
  end;

  message_list=record
      msgtext:msgline;
  end;

  newmess_list=record
      newmess:msgline;
  end;

var
  summary_file:file of summary_list;
  summary_rec:summary_list;

  newsumm_file:file of newsumm_list;
  newsumm_rec:newsumm_list;

  user_file:file of userlist;
  user_rec:userlist;

  stat_file:file of stat_list;
  stat_rec:stat_list;

  message_file:file of message_list;
  message_rec:message_list;

  newmess_file:file of newmess_list;
  newmess_rec:newmess_list;

  caller_file:file of caller_list;
  caller_rec:caller_list;

  comment_file:file of comment_list;
  comment_rec:comment_list;

  comfile:file;
  f1,f:text;
  temp,temp2:allstrings;
  filename:string[14];
  messbuff: array[1..15] of msgline;
  msghead: array[1..5] of msgline;
  lastname,firstname,whoto,subto,passto,line:allstrings;
  mfirst,mlast,message_pointer,rnum,knum,gg,lmsgs,code,message,zz,flag,d,ff,sp,c,a,b,n,i,x,y,z,lento,lc:integer;
  page,prt,fflag:boolean;
  dd,option,aa: char;


function StUpCase(st:allstrings):allstrings;
  begin
    for i := 1 to length(st) do
      St[i] := UpCase(st[i]);
    StUpCase := St
  end;

{this procedure converts the string in <temp> to
 an integer and returns it in x}
procedure makenum;

label done;
 begin
  x:=0;
  z:=0;
  if temp='' then goto done;
  y:=length(temp);
  dd:=copy(temp,y,1);
  if dd='+' then temp:=copy(temp,1,y-1);
  val(temp,x,z);
  if z<>0 then x:=30000; {error, so return absurd #}

 done:
 end;

{This procedure pads a string with spaces and returns
 it in temp. Use like: pad(input,padlength)}

procedure pad(var line:allstrings;l:integer);
label done;

begin
if length(line)>=l then goto done;
for i:=length(line)+1 to l do
 begin
  line:=line+' ';
 end;
temp:=line;
done:end;

{This procedure gets a Y/N response from user and
 puts it in dd.}

procedure pprompt;

begin
gg:=0;      {Reset all purpose page counter}
write('More? ');
readln(temp);
if temp='' then temp:=' ';
temp:=stupcase(temp);
dd:=copy(temp,1,1);
end;

{This procedure prints out a line. If the PRT toggle
 is ON, it also sends it to the printer}

procedure print;

begin
writeln(line);
if prt then
 begin
  i:=mem[3];
  mem[3]:=2;
  writeln(line);
  mem[3]:=i;
 end;
line:='';
end;

{This procedure reads and prints out the callers
 file and, at the operators descretion, creates a
 new file.}

procedure callers;
label loop,query,done;

begin
assign(caller_file,drive2+'CALLERS'+ext);
reset(caller_file);
read(caller_file,caller_rec);
with caller_rec do
 begin
  temp:=caller;
  makenum;
  if x=1 then goto query;
  gg:=0;
  dd:='Y';
  for i:=1 to x-1 do
   begin
    read(caller_file,caller_rec);
    line:='Name: '+caller;
    print;
    line:='From: '+cfrom;
    print;
    line:='Date: '+cdate;
    print;
    line:='Time: '+ctime;
    print;
    print;
    gg:=gg+1;
    if gg=5 then pprompt;
    if dd='N' then goto query;
   end;
 end;
query:
write('Do you wish to restart the CALLERS file? ');
readln(temp);
if temp='' then temp:='N';
dd:=copy(temp,1,1);
dd:=stupcase(dd);
if dd<>'Y' then goto done;
close(caller_file);
erase(caller_file);
assign(caller_file,drive2+'CALLERS'+ext);
with caller_rec do
 begin
  rewrite(caller_file);
  caller:='1';
  write(caller_file,caller_rec);
 end;

done:
close(caller_file);
end;

{This procedure reads and prints out the comments
 file and, at the operators descretion, creates a
 new file.}

procedure comments;
label loop,query,done;

begin
assign(comment_file,drive2+'COMMENTS'+ext);
reset(comment_file);
read(comment_file,comment_rec);
with comment_rec do
 begin
  temp:=comment;
  makenum;
  if x=1 then goto query;
  gg:=0;
  dd:='Y';
  for i:=1 to x-1 do
   begin
    read(comment_file,comment_rec);
    if pos('From',comment)<>0 then print;gg:=gg+1;
    line:=comment;
    print;
    gg:=gg+1;
    if gg>15 then pprompt;
    if dd='N' then goto query;
   end;
 end;
query:
write('Do you wish to restart the COMMENTS file? ');
readln(temp);
if temp='' then temp:='N';
dd:=copy(temp,1,1);
dd:=stupcase(dd);
if dd<>'Y' then goto done;
close(comment_file);
erase(comment_file);
assign(comment_file,drive2+'COMMENTS'+ext);
with comment_rec do
 begin
  rewrite(comment_file);
  comment:='1';
  write(comment_file,comment_rec);
 end;

done:
close(comment_file);
end;

{This procedure displays the entire message file.}

procedure messages;
label done;

begin
assign(message_file,drive3+'MESSAGES'+ext);
reset(message_file);
dd:='Y';
print;
while not eof(message_file) do
 begin
  read(message_file,message_rec);
  with message_rec do
   begin
    line:=msgtext;
    print;
    if msgtext='9999' then
     begin
      print;
      pprompt;
      if dd='N' then goto done;
      print;
     end;
   end;
 end;

done:
writeln('Message file shown.');
close(message_file);
end;

{This procedure access the summary file}
procedure summary;
label done;

begin
assign(summary_file,drive3+'SUMMARY'+ext);
reset(summary_file);
dd:='Y';
gg:=0;
print;
while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
    str(msgnum,temp);
    line:='Msg #    : '+temp;
    print;
    line:='From     : '+person_from;
    print;
    line:='To       : '+person_to;
    print;
    line:='Subject  : '+subject;
    print;
    line:='Date     : '+mdate;
    print;
    line:='Password : '+mpassword;
    print;
    str(no_of_lines,temp);
    line:='Lines    : '+temp;
    print;
    print;
    print;
    gg:=gg+1;
    if gg=2 then
     begin
      gg:=0;
      pprompt;
      if dd='N' then goto done;
     end;
   end;
 end;

done:
close(summary_file);
end;


{This procedure repacks the summary,counters and messages files}
procedure pack;
label next,loop;

begin
write('Repacking summary file...');
mfirst:=0;
assign(summary_file,drive3+'SUMMARY'+ext);
assign(newsumm_file,drive3+'SUMMARY.NEW');
reset(summary_file);
rewrite(newsumm_file);
while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
    if msgnum<>0 then
     begin
      if mfirst=0 then mfirst:=msgnum;
      with newsumm_rec do
       begin
        bmsgnum:=msgnum;
        bperson_from:=person_from;
        bperson_to:=person_to;
        bsubject:=subject;
        bmdate:=mdate;
        bmpassword:=mpassword;
        bno_of_lines:=no_of_lines;
        bprev_no_lines:=prev_no_lines;
       end;
      write(newsumm_file,newsumm_rec);
     end;
   end;
 end;
close(summary_file);
erase(summary_file);
close(newsumm_file);
rename(newsumm_file,drive3+'SUMMARY'+ext);
writeln;
write('Updating counter file...');
assign(stat_file,drive3+'COUNTERS'+ext);
reset(stat_file);
read(stat_file,stat_rec);
with stat_rec do
 begin
  seek(stat_file,filepos(stat_file)-1);
  msgs:=msgs;
  calls:=calls;
  mstart:=mfirst;
  mnum:=mnum;
  write(stat_file,stat_rec);
 end;
close(stat_file);
writeln;
write('Repacking message file...');
assign(message_file,drive3+'MESSAGES'+ext);
assign(newmess_file,drive3+'MESSAGES.NEW');
reset(message_file);
rewrite(newmess_file);
while not eof(message_file) do
 begin
  read(message_file,message_rec);
  with message_rec do
   begin
    line:=copy(msgtext,1,2);
    if line='0:' then goto loop;
    with newmess_rec do
     begin
      newmess:=msgtext;
      write(newmess_file,newmess_rec);
      goto next;
     end;
    loop:
    while msgtext<>'9999' do
     begin
      read(message_file,message_rec);
     end;
    next:
   end;
end;
close(message_file);
erase(message_file);
close(newmess_file);
rename(newmess_file,drive3+'MESSAGES'+ext);
writeln;
writeln(chr(7),'Repacking complete.');
end;

{This procedure access the user file}
procedure user;
label done;

begin
assign(user_file,drive3+'USER'+ext);
reset(user_file);
dd:='Y';
gg:=0;
print;
while not eof(user_file) do
 begin
  read(user_file,user_rec);
  with user_rec do
   begin
    line:='Name          : '+name;
    print;
    line:='Address       : '+address;
    print;
    line:='Password      : '+userpassword;
    print;
    str(lastmessage,temp);
    line:='Last high msg : '+temp;
    print;
    line:='Last date/time: '+lastdate;
    print;
    print;
    gg:=gg+1;
    if gg=3 then
     begin
      gg:=0;
      pprompt;
      if dd='N' then goto done;
     end;
   end;
 end;

done:
close(user_file);
end;

procedure get_command;
label start;

begin
 start:
  write('Function: L,C,M,S,E,T,P,U (? for HELP) :');
  temp:='';
  readln(temp);
  if temp<>'' then
   begin
    temp:=stupcase(temp);
    ff:=pos(temp,'LCMSE?TPU');
    if ff=0 then
      begin
        writeln('I don','''','t understand ','''',temp,'''',', SYSOP.');
        writeln;
        goto start;
      end;
   end;
end;

procedure do_command;
{Process command}
begin
if temp<>'' then
begin
case ff of

 1: begin
     callers;
    end;

 2: begin
     comments;
    end;

 3: begin
     messages;
    end;

 4: begin
     summary;
    end;

 5: begin
     bdos(0);
    end;

 6: begin
     writeln;
     writeln('           [Turbo BBS Utility Menu]');
     writeln;
     writeln('L: Log file            C: Comments file');
     writeln('M: Message file        S: Summary file');
     writeln('E: Exit to system      T: print Toggle');
     writeln('P: rePack system files U: User file');
     writeln;
    end;

 7: begin
     prt:=not prt;
     temp:='++ Printer toggle ';
     if prt then temp:=temp+'ON ++'
     else temp:=temp+'OFF ++';
     writeln(temp);
    end;

 8: begin
     pack;
    end;

 9: begin
     user;
    end;

end;
end;
end;


{Main program starts here}

begin

prt:=false;
write(chr(26));
writeln('Turbo Pascal BBS Utility Program');
writeln;
loop:
get_command;
do_command;
goto loop;

done:
end.

(26));
writeln('Turbo Pascal BBS Utility Program');
writeln;
loop:
get_command;
do_command;
goto