{*************************************************}
{ RBBSFUNC.INC   This include file contains the   }
{ following general purpose routines common to the}
{ program modules RBBS.PAS and RBBSMESG.PAS       }
{ STUPCASE
  MAKENUM
  PAD
  PPROMPT
  GTLN
  PRINTSTRING
  GETSTRING}

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 <bstring> to
 an integer and returns it in x}
procedure makenum;

label done;
 begin
  x:=0;
  z:=0;
  if bstring='' then goto done;
  y:=length(bstring);
  dd:=copy(bstring,y,1);
  if dd='+' then bstring:=copy(bstring,1,y-1);
  val(bstring,x,z);
  if z<>0 then x:=30000;

 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;


procedure byebye;
begin
  writeln('Thank you for calling, ',firstname,'.');
  writeln('Please call ',system,' again.');
  mem[0]:=$C3;    {Restore jump}
  mem[$80]:=0;    {Reset chain flag}
  fflag:=false;
  assign(comfile,drive1+'bye.com');
  execute(comfile);
end;

procedure printstring;
  label stop2,stop1,stop;
  begin
    brk:=false;
    if save<>'' then n:=0;
    if (save<>'') and (line1<>'') then
      begin
        line1:='';
        goto stop;
      end;
    if line1<>'' then
      begin
        line:=line1;
        line1:='';
      end;
    if keypressed then
      begin
        bi:=bios(2);
        if bi=11 then
          begin
            brk:=true;
            goto stop;
          end;
        if bi=19 then
          begin
            repeat
              inline($00/
                     $00);
            until keypressed;
          end;
      end;
    if (n=1) then
      begin
        if uppercase then line:=stupcase(line);
        write(line);
        pp:=line;
        goto stop1;
      end;
      if uppercase then line:=stupcase(line);
      writeln(line);
      stop1:a:=a+length(line);
      stop2:line:='';
      n := 0;
  stop:end;


{:: GetLine Procedure
 ::
 :: Set the VAR string parameter to user input, restricted to
 :: a set of allowed characters, less than or equal to allowed length.
 ::
 }

procedure gtln(VAR s:msgline; okset:charset; maxlen:integer);
var len:   integer;
    first,
    last:  boolean;
    getset:charset;
label done;

  function getchar(okset:charset):char;
  label loop,chrd,done;

  begin
    repeat
     i:=0;
     timer:=0.00;
  loop:if keypressed then goto chrd;
        timer:=timer+1.00;
        if timer>239400.00 then goto done;  {Timeout value is 1330 per second}
       goto loop;

chrd:  read(KBD,dd);
      if eoln(KBD) then dd:=^M;
      ok:=dd in okset;
      if not ok
        then write(CON,^G)
        else if dd in alphaset then write(CON,dd)
    until ok;
    getchar:=dd;
done:
  end;  {getchar}

begin
  temp:='';
  dd:=' ';
  repeat
    len:=length(temp);
    first:=len=0;
    last:=len=maxlen;
    if first then getset:=okset+[^M]
      else if last then getset:=[^M,^H]
      else getset:=okset+[^M,^H];
    dd:=getchar(getset);
    if timer>239400.00 then goto done;
    if dd=^H then
      begin
        write(^H,' ',^H);
        delete(temp,len,1)
      end
    else if dd in okset-[^M] then temp:=temp+dd
  until dd=^M;
  s:=temp;

done:
end;  {gtln}

procedure getstring;

  label loop,stop2,skip,stop,stop1;
  begin
   if ln=0 then ln:=62;
   loop:if (bel) and (save='') then write(^G);
    bstring:='';
    bk:=0;
    if save='' then
     begin
      gtln(save,alphaset,ln);
      if timer>239400.00 then byebye;
     end;
    writeln;
    ln:=62;
    sp:=pos(';',save);
    if sp=0 then
      begin
        bstring:=save;
        save:='';
        goto stop1;
      end;
    bstring:=copy(save,1,sp-1);
    save:=copy(save,sp+1,length(save));
    stop1: if length(bstring)=0 then
      goto stop;
    if c=0 then
      goto skip;
    bstring:=Stupcase(bstring);
    skip:
    stop2:d:=d+length(bstring);
  stop:end;

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

procedure pprompt;

begin
write('More? ');
gtln(temp3,alphaset,5);
writeln;
if temp3='' then temp3:=' ';
temp3:=stupcase(temp3);
dd:=copy(temp3,1,1);
end;

procedure prnttext;
  label stop;
  begin
    gg:=1;
    assign(f,filename);
    {$I-}
    reset(f);
    {$I+}
    if ioresult<>0 then
      goto stop;
    while not eof(f) do
    begin
      if brk then goto stop;
      readln(f,line);
      printstring;
      gg:=gg+1;
      if gg=15 then
       begin
        gg:=1;
        pprompt;
        if dd='N' then goto stop;
       end;
    end; {whil not eof(f)}
    for i:=1 to 3 do
      writeln;
  stop:close(f);
  end;


procedure getcpm;
begin
  filename:='CPMHELP';
  prnttext;
  writeln('Entering CPM...');
  mem[0]:=$C3;   {Restore jump}
  mem[$80]:=0;   {Reset chain flag}
  fflag:=false;
  bdos(0);
end;

procedure entr_comment;
label start,loop,fileit;
begin
 assign(comment_file,drive2+'COMMENTS'+ext);
 reset(comment_file);
 read(comment_file,comment_rec);
 with comment_rec do
  begin
   bstring:=comment;
   makenum;
   z:=x;
  end;
 frtemp:='From: '+firstname+' '+lastname+'.';
 writeln('Enter comments, 15 lines max. (C/R to end)');
 writeln('  I------------------------------------------------------------I');
 gg:=1;
 loop:
 str(gg,temp);
 temp:=temp+'>';
 write(temp);
 getstring;
 if bstring='' then goto fileit;
 messbuff[gg]:=bstring;
 gg:=gg+1;
 if gg<>16 then goto loop;

fileit:
 gg:=gg-1;
 with comment_rec do
  begin
   seek(comment_file,z);
   comment:=frtemp;
   write(comment_file,comment_rec);
   for i:=1 to gg do
    begin
     comment:=messbuff[i];
     write(comment_file,comment_rec);
    end;
   seek(comment_file,0);
   z:=z+(gg+1);
   str(z,temp);
   comment:=temp;
   write(comment_file,comment_rec);
   close(comment_file);
  end;
 if flag=1 then byebye;
 if flag=0 then getcpm;
end;

procedure goodbye;
begin
  flag:=1;
  line1:='Enter PRIVATE comments for the Sysop (Y/N) ?';
  n:=1;printstring;
  getstring;
  if (bstring='y') or (bstring='Y') then
    entr_comment;
  byebye;
end;

procedure exit_to_cpm;
label loop,match;
begin
if opencpm then goto match;
for i:=1 to 3 do
 begin
  line1:=query;
  n:=1;printstring;
  c:=1;getstring;c:=0;
  if bstring=answer then goto match;
 end;
line:='++ Only three tries allowed. Terminating session. ++';
printstring;
byebye;

match:
  flag:=0;
  line1:='Want to leave private comments for Sysop?';n:=1;
  printstring;
  getstring;
  if (bstring='Y') or (bstring='y') then
    entr_comment;
  getcpm;
end;

procedure prntuser;
label done;

begin
  gg:=0;
  line:='Name                 Address              Last on';
  printstring;
  writeln;
  assign(user_file,drive2+'USER'+ext);
  reset(user_file);
  while not eof(user_file) do
  begin
   read(user_file,user_rec);
   with user_rec do
   begin
    temp:=name;
    pad(temp,20);
    line:=temp+' ';
    temp:=address;
    pad(temp,20);
    line:=line+temp+' '+lastdate;
    printstring;
    gg:=gg+1;
    if gg=14 then
     begin
      gg:=0;
      pprompt;
      if dd='N' then goto done;
     end;
   end;
  end;
done:close(user_file);
end;


{This procedure returns the current time in the
global variable TIME}
procedure gettime;
var address,buff:integer;

begin
ptime:='';
if clock then
 begin
  address:=mem[$040]+256*mem[$041];
  buff:=mem[address+3];
  if buff<10 then ptime:='0';
  str(buff,temp);
  ptime:=ptime+temp+':';
  buff:=mem[address+4];
  if buff<10 then ptime:=ptime+'0';
  str(buff,temp);
  ptime:=ptime+temp+':';
  buff:=mem[address+5];
  if buff<10 then ptime:=ptime+'0';
  str(buff,temp);
  ptime:=ptime+temp;
 end;
end;

{This procedure returns the current date in the
global variable DATE}
procedure getdate;
var address,buff:integer;

begin
pdate:='';
if clock then
 begin
  address:=mem[$040]+256*mem[$041];
  buff:=mem[address-11];
  str(buff,temp);
  pdate:=pdate+temp;
  buff:=mem[address-10];
  str(buff,temp);
  pdate:=pdate+temp+'/';
  buff:=mem[address-9];
  buff:=buff-4;
  str(buff,temp);
  pdate:=pdate+temp;
  buff:=mem[address-8];
  str(buff,temp);
  pdate:=pdate+temp+'/';
  buff:=mem[address-13];
  str(buff,temp);
  pdate:=pdate+temp;
  buff:=mem[address-12];
  str(buff,temp);
  pdate:=pdate+temp;
 end;
end;