The Devil's Doorknob BBS Capture (1996-2003)/devilsdoorknobbbscapture1996-2003.iso/Dloads/OTHERUTI/WWIV310S.ZIP/DOS.PAS

Pascal/Delphi Source File | 1986-04-01 | 42KB | 1,436 lines

program dos;

{$V-} {$C-}
TYPE j=array[1..8] of string[14];

CONST strlen=160;
      comnum=1;
      maxbaud=1200;
      maxusers=300;
      dsaves : Integer = 0;
      buffer_Max    = 5120;
      comptyp:j=('IBM','APPLE','TRS-80','Z-80 CP/M','COMMODORE','ATARI',
                 'DUMB TERMINAL','OTHER');

TYPE str=string[strlen];
     restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
                   rpost,remail,rvoting,rmsg);
     acrq='@'..'G';
     newtyp=(rp,lt,rm);
     deflts=(spcsr,onekey,wordwrap,pause);
     anontyp=(no,yes,forced,dearabby);
     ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
     opts=(alert,smw,nomail);
     pnr=record name:string[40]; number:string[14]; hs:byte; end;
     slr=record
           ttime:byte;
           mallowed:integer;
           emails,posts:byte;
           anst:set of ansttype;
         end;
     messages=record
                ltr:char;
                number:integer;
                ext:byte;
              end;
     smalrec=record
               name:string[25];
               number:integer;
             end;
     userrec=record
               name:string[25];
               realname:string[14];
               deleted:boolean;
               pw:string[8];
               ph:string[12];
               waiting:byte;
               laston:string[10];
               loggedon:integer;
               msgpost:integer;
               emailsent:integer;
               feedback:integer;
               linelen:byte;
               pagelen:byte;
               defaults:set of deflts;
               ontoday:byte;
               illegal:byte;
               cursor:string[10];
               sl:byte;
               ac:set of restrictions;
               ar:set of acrq;
               qscan:array[1..19] of messages;
               qscn:array[1..19] of boolean;
               macro:array[1..2] of string[79];
               comptype:byte;
               option:set of opts;
               vote:array[1..9] of byte;
               sbn:byte;
               dsl:byte;
               uploads,downloads:integer;
               uk,dk:integer;
             end;
      boardrec=record
                 name:string[25];
                 filename:string[12];
                 sl:byte;
                 maxmsgs:byte;
                 pw:string[10];
                 anonymous:anontyp;
                 ar:acrq;
                 key:char;
               end;
      msgstat=(validated,unvalidated,deleted);
      messagerec=record
                   title:string[30];
                   messagestat:msgstat;
                   message:messages;
                   owner:integer;
                   date:integer;
                   mage:byte;
                 end;
      systatrec=record
                  boardpw:string[8];
                  sysoppw:string[8];
                  hmsg:messages;
                  users:integer;
                  lastdate:string[8];
                  callernum:integer;
                  activetoday:integer;
                  callstoday:integer;
                  msgposttoday:integer;
                  emailtoday:integer;
                  fbacktoday:integer;
                  uptoday:integer;
                  closedsystem:boolean;
                end;
      blk=array[1..255] of byte;
      mailrec=record
                title:string[30];
                from,destin:integer;
                msg:messages;
                date:integer;
                mage:byte;
              end;
      gft=record
            num:integer;
            title:string[40];
            filen:string[12];
          end;
      charfil=text;
      smr=record
            msg:str;
            destin:integer;
          end;
      vdatar=record
               question:string[79];
               numa:integer;
               answ:array[0..9] of record
                      ans:string[25];
                      numres:integer;
                    end;
             end;
      regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
      ulrec=record
              name:string[25];
              filename:string[12];
              password:string[10];
              dsl:byte;
              maxfiles:integer;
            end;
      strptr=^strrec;
      strrec=record
               i:str;
               next,last:strptr;
             end;

var sf:file of smalrec;
    uf:file of userrec;
    bf:file of boardrec;
    mf:file of messagerec;
    mailfile:file of mailrec;
    sysopf:charfil;
    slf:file of slr;
    seclev:array[0..255] of slr;
    systatf:file of systatrec;
    systat:systatrec;
    sr:smalrec;
    thisline,chatr,buf,spd,irt,lastname,ll,cursor,ix:str;
    thisuser,user:userrec;
    boards:array[1..19] of boardrec;
    fw,extramsgs,mread,board,numboards,t,usernum:integer;
    pap,lil,realsl,ftoday,ptoday,etoday:integer;
    c,ID:char;
    hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
    extratime,timeon:real;
    macok,lan,enddayf,ch,quit:boolean;
    buffer:Array[0..buffer_Max] of Char;
    comport,base:Integer;
    Async_Irq:Integer;
    buffer_Head,buffer_tail,buffer_newtail:Integer;
    smf:file of smr;
    srl:array[0..maxusers] of smalrec;
    vqu:array[1..9] of boolean;
    ret:byte absolute cseg:$0080;
    ldate:integer;
    maxspd:integer;
    cmd:char;
    help:array[1..25000] of char;
    helpi:array['0'..'^'] of integer;
    helpl:char;
    ihelp:boolean;
    cf:text; cfo,okt:boolean;
    elevel:byte;
    topheap:^byte;
    i1:str;
    i:array[1..9] of string[79];
    donedos,dld,d1,d2,done,abort:boolean;
    c1,c2,c3:integer;
    f,f1:file of byte;
    x:byte;
    cd:str;
    s1,s2,s3:str;
    all:boolean;
    chksum:byte;
    crc:integer;
    ucrc,ymodem:boolean;
    fat,dta:string[44];
    ft:byte;
    lastvar:byte;

label reent;

{$I COMMON.PAS}

function tcheck(s:real; i:integer):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if trunc(r-s)>i then tcheck:=false else tcheck:=true;
end;

function tchk(s:real; i:real):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if (r-s)>i then tchk:=false else tchk:=true;
end;

{$I DLP1.PAS}

function okfile(fn:str):boolean;
begin
  okfile:=(pos('.LST',FN)=0) and (pos('.DAT',fn)=0) and (pos('.   ',fn)=0)
          and (pos('.FIL',fn)=0) and (pos('.TRM',fn)=0) and (pos('.LOG',fn)=0);
  if (not so) and (pos('.TXT',fn)=0) and (pos('.MSG',fn)=0)and (pos('.???',FN)=0)
    then okfile:=false;
end;

procedure printfile(fn:str);
var fil:text;
    i:str;
    abort,next:boolean;
begin
 if not hangup then begin
  assign(fil,fn);
  {$I-} reset(fil); {$I+}
  if ioresult<>0 then print('File not found.') else begin
    abort:=false;
    while not eof(fil) and (not abort) and (not hangup) do begin
      readln(fil,i);
      if i[length(i)]<>#1 then i:=i+#1;
      printa(i,abort,next);
    end;
    close(fil);
  end;
  nl;nl;
 end;
end;

procedure inli(var i:str);
var cp,rp:integer; c:char; cv,cc:integer;
begin
  rp:=1; cp:=1;
  i:='';
  if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1; rp:=cp;end;
  repeat
    getkey(c); skey(c);
    case ord(c) of
      32..126:if (cp<strlen) and (rp<thisuser.linelen) then begin
                i[cp]:=c; cp:=cp+1; rp:=rp+1; outkey(c); thisline:=thisline+c;
              end;
            127,8:if cp>1 then begin c:=chr(8);
                if i[cp-1]=chr(8) then begin prompt(' '); rp:=rp+1; end else
                 if i[cp-1]<>chr(10) then
                   begin prompt(c+' '+c); rp:=rp-1; end;
                cp:=cp-1;
              end;
           24:begin
                cp:=1; for cv:=1 to rp-1 do prompt(chr(8)+' '+chr(8));
                rp:=1;
              end;
           23:if cp>1 then repeat
                prompt(chr(8)+' '+chr(8)); rp:=rp-1; cp:=cp-1;
              until (cp=1) or (i[cp]=' ') or (i[cp]=chr(8));
           14:if (not (rbackspace in thisuser.ac)) and (rp>1) and (cp<strlen) then begin
                prompt(chr(8)); i[cp]:=chr(8); cp:=cp+1; rp:=rp-1;
              end;
           10:if (not (rbackspace in thisuser.ac)) and (cp<strlen) then begin
                prompt(c); i[cp]:=c; cp:=cp+1;
              end;
            9:begin
                cv:=5-(cp mod 5); if (cp+cv<strlen) and (rp+cv<thisuser.linelen) then
                  for cc:=1 to cv do begin
                    rp:=rp+1; prompt(' ');
                    i[cp]:=' '; cp:=cp+1;
                  end;
              end;
  end;
  until (c=chr(13)) or ((rp=thisuser.linelen) and (wordwrap in thisuser.defaults)) or hangup;
  i[0]:=chr(cp-1);
  if c<>chr(13) then begin
    cv:=cp-1;
    while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
    if (cv>(rp div 2)) and (cv<>cp-1) then begin
      ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
      for cc:=cp-2 downto cv do prompt(' ');
      i[0]:=chr(cv-1);
    end;
  end;
  nl;
  if c=chr(13) then i:=i+chr(1);
end;

procedure ul;
var dok,abort:boolean; i:str;
f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Send file: ');
  input(i,12);
  i:='dloads\'+i;
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    close(f);
    send1(i,dok,abort);
  end else print('File not found.');
  incom:=false;
  hangup:=false;
  outcom:=false;
  writeln;
end;

procedure dl;
var dok:boolean; i:str; f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Receive file: ');
  input(i,12);
  i:='dloads\'+i;
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult<>0 then begin
    {$I-} rewrite(f); {$I+}
    if ioresult=0 then begin
      close(f);
      dok:=true;
    end else begin
      dok:=false;
      print('Illegal filename.');
    end;
  end else begin
    close(f);
    print(#7+'File already exists.');
    prompt('Overwrite? ');
    dok:=yn;
  end;
  if dok then
    receive1(i,dok);
  hangup:=false;
  incom:=false;
  outcom:=true;
end;

procedure term;
var c:char; done,bac,eco:boolean;
    hs:byte;
    ns:array[1..9] of pnr;
    fil:file of pnr;
    lnd,i:integer;
    maxs:byte;

  procedure pc(s:str);
  var i:integer;
  begin
    s:=s+chr(13);
    for i:=1 to length(s) do o1(s[i]);
  end;

  procedure cs(hs:byte);
  begin
    writeln;
    case hs of
      0:begin
          set_baud(300);
          writeln('--- 300 BAUD ---');
        end;
      1:begin
          set_baud(1200);
          writeln('=== 1200 BAUD ===');
        end;
      2:begin
          set_baud(2400);
          writeln('=-= 2400 BAUD =-=');
        end;
    end;
    writeln;
  end;

  procedure tab(x:integer);
  begin
    while wherex<x do write(' ');
  end;

  procedure dial;
  var i:integer; done:boolean; c:char; s:str;
  begin
    done:=false;
    repeat
      writeln;
      write('Dial: 1-9,M,Q,? : ');
      repeat
        read(kbd,c); c:=upcase(c);
      until c in ['1'..'9','M','Q','?'];
      writeln(c); writeln;
      if c='Q' then begin done:=true; writeln; writeln('Back in term mode.'); writeln; end;
      if c='?' then begin
        clrscr;
        writeln('N NAME                                      NUMBER         SPD');
        writeln('- ----------------------------------------  -------------  ----');
        for i:=1 to 9 do begin
          write(i,' ',ns[i].name); tab(44); write(ns[i].number); tab(60);
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
        end;
      end;
      if c='M' then begin
        write('Which (1-9) ? ');
        repeat
          read(kbd,c);
        until c in ['1'..'9',#13];
        if c in ['1'..'9'] then begin
          i:=value(c);
          clrscr;
          writeln('Number: ',i);
          writeln;
          writeln('Old Name: ',ns[i].name);
          write('New Name: '); inputl(s,40);
          if s<>'' then ns[i].name:=s;
          writeln;
          writeln('Old Number: ',ns[i].number);
          write('New Number: '); input(s,14);
          if s<>'' then ns[i].number:=s;
          writeln;
          write('Old Speed: ');
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
          writeln;
          writeln('0 =  300');
          if maxs>0 then writeln('1 = 1200');
          if maxs>1 then writeln('2 = 2400');
          write('New speed? '); read(kbd,c); if (c<'0') or (c>'2') then c:=#0;
          writeln(c); writeln;
          if (value(''+c)<=maxs) and (c<>#0)  then ns[i].hs:=value(''+c);
          reset(fil); seek(fil,i-1); write(fil,ns[i]); close(fil);
          c:=' ';
        end;
      end;
      if c in ['1'..'9'] then begin
        done:=true;
        i:=value(c);
        clrscr; lnd:=i;
        hs:=ns[i].hs; cs(hs);
        writeln('Dialing: ',ns[i].name);
        writeln('At     : ',ns[i].number);
        writeln;
        pc('ATDT'+ns[i].number);
      end;
    until done;
  end;

  function cd:boolean;
  begin
    cd:=((port[base+6] and 128)<>0)
  end;

  procedure hang;
  var rl:real;
  begin
    dump;
    term_ready(false); rl:=timer;
    while cd and (abs(timer-rl)<1.5) do;
    term_ready(true);
  end;

  procedure redial;
  var c:char; done:boolean; try:integer; rl,rl1:real; int:integer; i,i1:str;
  begin
    clrscr; try:=0;
    hs:=ns[lnd].hs; cs(hs); rl:=timer;
    pc('ATM0Q0V0E0S7=16');
    writeln('Re-Dialing: ',ns[lnd].name);
    writeln('At        : ',ns[lnd].number);
    writeln('Try       : 0');
    writeln('Time      : 00:00');
    writeln; writeln('Hit <ESC> to abort'); done:=false;
    delay(500); dump;
    repeat
      pc('ATDT'+ns[lnd].number);
      try:=try+1;
      gotoxy(13,6); writeln(try);
      rl1:=timer; if rl1<rl then rl:=rl+24.0*3600.0;
      int:=trunc(rl1-rl);
      i:=cstr(int div 60);
      if length(i)=1 then i:='0'+i;
      i1:=cstr(int mod 60);
      if length(i1)=1 then i1:='0'+i1;
      i:=i+':'+i1;
      gotoxy(13,7); writeln(i); dump;
      while (not done) and (not commpressed) do begin
        if keypressed then begin
          read(kbd,c); if c=#27 then begin done:=true; o1('A'); end;
        end;
      end;
      delay(100);
      if cd then done:=true else dump;
    until done;
    if cd then for try:=1 to 6 do begin
      sound(1200); delay(200); nosound; delay(100);
    end else begin
      delay(500); pc('ATM1Q0V1E1S7=30');
    end;
    gotoxy(1,14); writeln; writeln('Back in term mode...');
  end;

  procedure help;
  var x,y,c:integer;
  begin
    x:=wherex; y:=wherey;
    for c:=1 to 10 do begin
      gotoxy(42,c); write(#$b3);
    end;
    gotoxy(42,11); write(#$c0);
    while wherex<>1 do write(#$c4);
    window(43,1,80,10); clrscr;
    window(45,1,80,10); gotoxy(1,1);
    writeln('Alt-B = backspacing toggle');
    writeln('Alt-C = clear screen');
    writeln('Alt-D = dial number');
    writeln('Alt-E = echo toggle');
    writeln('Alt-H = hang up phone');
    writeln('Alt-Q = redial last number');
    writeln('Alt-S = speed toggle');
    writeln('Alt-X = exit');
    writeln('PgUp  = send file from dloads');
    write('PgDn  = receive file into dloads');
    window(1,1,80,25); gotoxy(x,y);
  end;

begin
  clrscr; lnd:=0; eco:=false;
  if maxspd=300 then maxs:=0;
  if maxspd=1200 then maxs:=1;
  if maxspd=2400 then maxs:=2;
  assign(fil,'gfiles\numbers.trm');
  reset(fil);
  for i:=1 to 9 do read(fil,ns[i]);
  close(fil);
  writeln('Press [HOME] for help');
  writeln;
  hs:=maxs; cs(hs); bac:=false;
  done:=false; mem[$40:$17]:=mem[$40:$17] or $40;
  pc('ATQ0V1E1S2=43M1S11=50');
  repeat
    if commpressed then begin
      c:=cinkey; if c=chr(12) then clrscr else
        if c=chr(8) then begin
          bs; if bac then begin write(' '); bs; end
        end else if c<>chr(0) then write(c);
      end;
    if keypressed then begin
      read(kbd,c);
      if c=chr(27) then
        if keypressed then begin
          read(kbd,c); case ord(c) of
            48:begin bac:=not bac; writeln; writeln;
                 if bac then writeln('-Destructive-') else writeln('=Non-Destructive=');
                 writeln; writeln;
               end;
            45:done:=true;
            31:begin hs:=hs+1; if hs>maxs then hs:=0; cs(hs); end;
            32:dial;
            16:if (lnd>0) and (lnd<10) then redial;
            35:hang;
            73:ul;
            81:dl;
            71:help;
            46:clrscr;
            18:begin eco:=not eco; writeln; writeln;
                 if eco then writeln('-= ECHO ON =-') else writeln('=- ECHO OFF -=');
                 writeln; writeln;
               end;
          end;
      end else else begin o1(c); if eco then write(c); end;
    end;
  until done;
  hang; delay(1000); pc('ATS0=0Q0V0E0M0S2=1S7=30'); delay(100); dump;
  mem[$40:$17]:=mem[$40:$17] and not $40;
end;

procedure voteprint;
var vdata:file of vdatar; vd:vdatar; vn:integer; t:text; i1,i2:integer; u:userrec;
    x:array[1..maxusers] of array[1..9] of integer;
    s1,s2:str;

begin
  assign(t,'gfiles\votes.txt');
  rewrite(t);
  writeln(t); writeln(t,'Votes as of '+dat);
  reset(uf);
  print('Beginning output to file "VOTES.TXT"');
  i1:=1;
  while (i1<filesize(uf)) do begin
    seek(uf,i1); read(uf,u);
    for i2:=1 to 9 do
      x[i1][i2]:=u.vote[i2];
    i1:=i1+1;
  end;
  close(uf);
  assign(vdata,'gfiles\voting.dat');
  reset(vdata);
  for vn:=1 to 9 do begin
    seek(vdata,vn-1); read(vdata,vd);
    if vd.numa<>0 then begin
      writeln(t); writeln(t,vd.question);
      print(vd.question);
      for i1:=1 to vd.numa do begin
        writeln(t,'   '+vd.answ[i1].ans);
        for i2:=1 to systat.users do begin
          if x[srl[i2].number][vn]=i1 then begin
            writeln(t,'      '+srl[i2].name+' #'+cstr(srl[i2].number));
          end;
        end;
      end;
    end;
  end;
  close(t);
  print('Output complete.');
end;

procedure return;
var f:file;
begin
  assign(f,'bbs.com');
  print('Returning to BBS...');
  remove_port;
  if hangup then term_ready(false);
  execute(f);
end;


procedure parse(i1:str);
var c,lp,cp:integer;
begin
  for c:=1 to 9 do i[c]:='';
  c:=1; lp:=1; cp:=1;
  if length(i1)=1 then i[1]:=i1;
  while cp<length(i1) do begin
    cp:=cp+1;
    if (i1[cp]=' ') or (cp=length(i1)) then begin
      if cp=length(i1) then cp:=cp+1;
      i[c]:=copy(i1,lp,(cp-lp));
      lp:=cp+1;
      c:=c+1;
    end;
  end;
end;

function align(fn:str):str;
var f,e,t:str; c,c1:integer;
begin
  c:=pos('.',fn);
  if c=0 then begin
    f:=fn; e:='   ';
  end else begin
    f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
  end;
  while length(f)<8 do f:=f+' ';
  while length(e)<3 do e:=e+' ';
  c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
  c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
  align:=f+'.'+e;
end;

function vdir(var d:str):boolean;
var x:boolean;
begin
  if d[length(d)]='\' then d:=copy(d,1,length(d)-1);
  if (d='DLOADS') or (d='GFILES') then x:=true else x:=false;
  if (d='.') and so then x:=true;
  vdir:=x;
end;

procedure fix(var fn:str);
var i,i1:str; c1,c2:integer; ok:boolean;
begin
  if vdir(fn) then fn:=fn+'\';
  c1:=pos('\',fn); ok:=true;
  if c1<>0 then begin
    i:=copy(fn,1,c1-1);
    fn:=copy(fn,c1+1,15);
    if not vdir(i) then ok:=false;
  end else i:='';
  if i='' then i:=cd;
  if fn='' then fn:='*.*';
  fn:=i+'\'+align(fn);
  if (pos('.MSG',fn)=0) and (pos('.TXT',fn)=0) and (pos('?',fn)=0) and (not so) then ok:=false;
  if not ok then fn:='';
  if not okfile(fn) then fn:='';
end;

function fit(f1,f2:str):boolean;
var tf:boolean; c:integer;
begin
  tf:=true;
  for c:=1 to 12 do
    if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
  fit:=tf;
end;

overlay procedure tedit;
var cur,nex,las,b4:strptr;
    top,bottom,used:strptr;
    tline,curline,c1,c2:integer;
    fil:text;
    abort,next,done,allread:boolean;
    i1,i2:str;

  function newptr(var x:strptr):boolean;
  begin
    if used<>nil then begin
      x:=used;
      used:=used^.next;
      newptr:=true;
    end else begin
      if (maxavail<0) or (maxavail>100) then begin
        new(x);
        newptr:=true;
      end else newptr:=false;
    end;
  end;

  procedure oldptr(var x:strptr);
  begin
    x^.next:=used;
    used:=x;
  end;

  procedure pline(cl:integer; var cp:strptr; var abort:boolean);
  var next:boolean; i:str;
  begin
    if not abort then begin
      if cp=nil then i:='      [END]' else begin
        i:=cstr(cl);
        while length(i)<4 do i:=' '+i;
        i:=i+': '+cp^.i;
      end;
      printacr(i,abort,next);
    end;
  end;

  procedure pl;
  var abort:boolean;
  begin
    abort:=false;
    pline(curline,cur,abort);
  end;

begin
  nl; allread:=true;
  used:=nil;
  top:=nil;
  bottom:=nil;
  fix(i[2]);
  if (pos('.MSG',i[2])=0) and (pos('.TXT',i[2])=0) then i[2]:='';
  if i[2]='' then print('Illegal filename.') else begin
    assign(fil,i[2]); abort:=false;
    {$I-} reset(fil); {$I+}
    tline:=0;
    new(cur);
    cur^.last:=nil;
    cur^.i:='';
    if ioresult<>0 then begin
      {$I-} rewrite(fil); {$I+}
      if ioresult<>0 then begin
        print('Illegal filename.');
        abort:=true;
      end else begin
        close(fil); erase(fil);
        print('New file.');
        tline:=0;
        cur:=nil; top:=cur; bottom:=cur;
      end;
    end else begin
      abort:=not newptr(nex);
      top:=nex;
      print('Loading...');
      while (not eof(fil)) and (not abort) do begin
        tline:=tline+1;
        cur^.next:=nex;
        nex^.last:=cur;
        cur:=nex;
        readln(fil,i1);
        cur^.i:=i1;
        abort:=not newptr(nex);
      end;
      close(fil);
      cur^.next:=nil;
      if tline=0 then begin cur:=nil; top:=nil; end;
      bottom:=cur;
      if abort then begin print('Not all of file read.'); allread:=false; end;
      abort:=false;
    end;
    if not abort then begin
      print('Total lines: '+cstr(tline));
      cur:=top;
      if top<>nil then top^.last:=nil;
      curline:=1;
      done:=false;
      pl;
      repeat
        prompt(':');
        input(i1,10);
        if i1='' then i1:='+';
        if value(i1)>0 then begin
          c1:=value(i1);
          if (c1>0) and (c1<=tline) then begin
            while c1<>curline do
              if c1<curline then begin
                if cur=nil then begin
                  cur:=bottom;
                  curline:=tline;
                end else begin
                  curline:=curline-1;
                  cur:=cur^.last;
                end;
              end else begin
                curline:=curline+1;
                cur:=cur^.next;
              end;
            pl;
          end;
        end else case i1[1] of
          '+':if cur<>nil then begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                while (cur<>nil) and (c1>0) do begin
                  cur:=cur^.next;
                  curline:=curline+1;
                  c1:=c1-1;
                end;
                pl;
              end;
          '?':begin
                print('P:rint line      L:ist');
                print('-:back line      +:forward line');
                print('T:op             B:ottom');
                print('I:nsert lines    D:elete line');
                print('R:eplace line    C:lear workspace');
                print('Q:uit            S:ave');
              end;
          '-':begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                if cur=nil then begin
                  cur:=bottom;
                  curline:=tline;
                  c1:=c1-1;
                end;
                if cur<>nil then
                  if cur^.last<>nil then begin
                    while (cur^.last<>nil) and (c1>0) do begin
                      cur:=cur^.last;
                      curline:=curline-1;
                      c1:=c1-1;
                    end;
                    pl;
                  end;
              end;
          'C':begin
                prompt('Clear workspace? ');
                if yn then begin
                  tline:=0; curline:=1;
                  cur:=nil; top:=nil; bottom:=nil;
                  release(topheap);
                end;
              end;
          'P':pl;
          'D':begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                while (cur<>nil) and (c1>0) do begin
                  las:=cur^.last;
                  nex:=cur^.next;
                  if las<>nil then las^.next:=nex;
                  if nex<>nil then nex^.last:=las;
                  oldptr(cur);
                  if bottom=cur then bottom:=las;
                  if top=cur then top:=nex;
                  cur:=nex;
                  tline:=tline-1;
                  c1:=c1-1;
                end;
                pl;
              end;
          'R':if cur<>nil then begin
                pl;
                i2:=cstr(curline); while length(i2)<>4 do i2:=' '+i2;
                i2:=i2+': '; prompt(i2);
                inli(i1);
                cur^.i:=i1;
              end;
          'I':begin
                abort:=false; ll:='';
                print('Enter "." on a seperate line to exit insert mode.');
                i1:=''; thisuser.linelen:=thisuser.linelen-6;
                while (not abort) and (i1<>'.') and (i1<>'.'+#1) do begin
                  i2:=cstr(curline); while length(i2)<>4 do i2:=' '+i2;
                  i2:=i2+': '; prompt(i2);
                  inli(i1);
                  if (i1<>'.') and (i1<>'.'+#1) then begin
                    abort:=not newptr(nex);
                    if not abort then begin
                      nex^.i:=i1;
                      if (top=cur) then
                        if cur=nil then begin
                          nex^.last:=nil;
                          nex^.next:=nil;
                          top:=nex;
                          bottom:=nex;
                        end else begin
                          nex^.next:=cur;
                          cur^.last:=nex;
                          top:=nex;
                        end
                      else begin
                        if cur=nil then begin
                          bottom^.next:=nex;
                          nex^.last:=bottom;
                          nex^.next:=nil;
                          bottom:=nex;
                        end else begin
                          las:=cur^.last;
                          nex^.last:=las;
                          nex^.next:=cur;
                          cur^.last:=nex;
                          las^.next:=nex;
                        end;
                      end;
                      curline:=curline+1;
                      tline:=tline+1;
                    end else print('No room left.');
                  end;
                end;
                thisuser.linelen:=thisuser.linelen+6;
              end;
          'T':begin
                cur:=top;
                curline:=1;
                pl;
              end;
          'B':begin
                cur:=nil;
                curline:=tline+1;
                pl;
              end;
          'L':begin
                abort:=false;
                nex:=cur;
                c1:=curline;
                while (not abort) and (nex<>nil) do begin
                  pline(c1,nex,abort);
                  nex:=nex^.next;
                  c1:=c1+1;
                end;
              end;
          'Q':done:=true;
          'S':begin
                if not allread then begin
                  prompt('Not all of file read.  Save anyway? ');
                  allread:=yn;
                end;
                if allread then begin
                  done:=true;
                  writeln('Saving...');
                  rewrite(fil);
                  cur:=top;
                  while cur<>nil do begin
                    writeln(fil,cur^.i);
                    cur:=cur^.next;
                  end;
                  close(fil);
                end;
              end;
        end;
      until done;
    end;
  end;
  release(topheap);
end;

overlay procedure gfileedit;
var b,b1:gft; f:file of gft; i:str; t,c:integer; ok,exit:boolean;
    gftit:array[1..150] of record tit:string[80]; arn:integer; gfile:boolean;end;
    nums,lgftn,numgft:integer;
    gfs:array[0..100] of record tit:string[80]; arn:integer; end;
    c1,c2,c3,c4:integer; s1,s2,s3,s4:str; ch:char;

  procedure gettit(n:integer);
  var r:integer; b:gft;
  begin
    numgft:=0;
    r:=n+1;
    if r<=t then begin
      seek(f,r); read(f,b);
      while (r<=t) and (b.filen[1]<>#1) do begin
        begin
          numgft:=numgft+1;
          gftit[numgft].tit:=b.title;
          gftit[numgft].arn:=r;
          gftit[numgft].gfile:=true;
        end;
        r:=r+1;
        if (r<=t) then begin seek(f,r); read(f,b);end;
      end;
    end;
  end;

  procedure getsec;
  var r:integer; b:gft;
  begin
    nums:=0;
    gfs[0].tit:='[ Main Section ]';
    gfs[0].arn:=0;
    for r:=1 to t do begin
      seek(f,r); read(f,b);
      if b.filen[1]=#1 then begin
        nums:=nums+1;
        gfs[nums].tit:='[ '+b.title+' ]';
        gfs[nums].arn:=r;
      end;
    end;
    gfs[nums+1].arn:=t+1;
  end;

  procedure listsec;
  var r:integer; i:str; abort,next:boolean;
  begin
    r:=0; abort:=false; nl; nl;
    while (r<=nums) and (not abort) do begin
      i:=cstr(r)+': '+gfs[r].tit;
      r:=r+1;
      printacr(i,abort,next);
    end;
  end;

  procedure lgft;
  var abort,next:boolean; c:integer; b:gft;
  begin
    nl; nl;
    if numgft=0 then print('No G-files.') else begin
      abort:=false; next:=false; c:=1;
      while (c<=numgft) and (not abort) do begin
        seek(f,gftit[c].arn); read(f,b);
        i:=cstr(c)+': '; if length(i)=3 then i:=' '+i;
        i:=i+b.filen;
        while length(i)<18 do i:=i+' ';
        i:=i+cstr(b.num);
        while length(i)<24 do i:=i+' ';
        i:=i+b.title;
        printacr(i,abort,next);
        c:=c+1;
      end;
    end;
  end;

begin
  nl;assign(f,'gfiles\gfiles.dat'); {$I-} reset(f); {$I+}
  if ioresult<>0 then begin
    rewrite(f); b.num:=0; write(f,b);
  end;
  seek(f,0); read(f,b); t:=b.num; exit:=false;
    repeat
      nl; nl;prompt('Gfile Edit: Q,I,D,S,? : ');
      onek(ch,'QIDS?'); getsec;
      case ch of
        'Q':exit:=true;
        '?':begin
              print('Q:uit from gfile edit   ?:this list');
              print('I:nsert G-file          D:delete G-file');
              print('S:ection modification');
            end;
        'S':begin
              prompt('I:nsert, D:elete, Q:uit ? '); onek(ch,'QID');
              case ch of
                'I':begin
                      listsec;
                      prompt('Before which section (1-'+cstr(nums+1)+') : '); input(s1,2);
                      c1:=value(s1);
                      if (c1>0) and (c1<=(nums+1)) then begin
                        if c1<=nums then
                          c1:=gfs[c1].arn
                        else
                          c1:=t+1;
                        prompt('Section title? '); inputl(b.title,40);
                        prompt('SL requirement? '); input(s1,3);
                        b.num:=value(s1); b.filen:=#1#0#0#0#0#0;
                        for c3:=t downto c1 do begin
                          seek(f,c3); read(f,b1); seek(f,c3+1); write(f,b1);
                        end;
                        seek(f,c1); write(f,b); t:=t+1;
                        b.num:=t; seek(f,0); write(f,b);
                      end else print('Illegal section number.');
                    end;
                'D':begin
                      listsec;
                      prompt('Delete which section (1-'+cstr(nums)+') : '); input(s1,2);
                      c1:=value(s1);
                      if ((c1>0) and (c1<=nums)) then begin
                        c2:=gfs[c1].arn;
                        if c1=nums then c3:=t+1 else c3:=gfs[c1+1].arn;
                        c1:=(c3-c2);
                        for c4:=c3 to t do begin
                          seek(f,c4); read(f,b); seek(f,c4-c1); write(f,b);
                        end;
                        seek(f,0); t:=t-c1; b.num:=t; write(f,b);
                      end;
                    end;
              end;
            end;
        'D':begin
              listsec;
              prompt('Which section (0-'+cstr(nums)+') : '); input(s1,2);
              c1:=value(s1);
              if (s1='0') or ((c1>0) and (c1<=nums)) then begin
                gettit(gfs[c1].arn);
                lgft;
                prompt('Delete which (1-'+cstr(numgft)+') :');
                input(s1,3);
                c1:=value(s1);
                if (c1>0) and (c1<=(numgft)) then begin
                  c1:=gftit[c1].arn;
                  for c2:=c1+1 to t do begin
                    seek(f,c2); read(f,b); seek(f,c2-1); write(f,b);
                  end;
                  seek(f,0); read(f,b); b.num:=b.num-1;
                  seek(f,0); write(f,b); t:=t-1;
                end;
              end;
            end;
        'I':begin
              listsec;
              prompt('Which section (0-'+cstr(nums)+') : '); input(s1,2);
              c1:=value(s1);
              if (s1='0') or ((c1>0) and (c1<=nums)) then begin
                gettit(gfs[c1].arn);
                lgft; c4:=c1;
                prompt('Insert before which (1-'+cstr(numgft+1)+') :');
                input(s1,3);
                c1:=value(s1);
                if (c1>0) and (c1<=(numgft+1)) then begin
                  if c1<=numgft then
                    c2:=gftit[c1].arn
                  else
                    c2:=gfs[c4+1].arn;
                  prompt('Enter filename of new G-file : ');
                  input(b.filen,12); if (pos('.TXT',b.filen)=0) and
                  (pos('.MSG',b.filen)=0) then b.filen:='';
                  assign(f1,'gfiles\'+b.filen); {$I-} reset(f1); {$I+}
                  ok:=false; if ioresult=0 then begin close(f1); ok:=true; end;
                  if b.filen='' then ok:=false;
                  if ok then begin
                    nl; prompt('Enter title : '); inputl(b.title,40);
                    prompt('Enter SL : ');
                    input(i,3); b.num:=value(i);
                    for c3:=t downto c2 do begin
                      seek(f,c3); read(f,b1); seek(f,c3+1); write(f,b1);
                    end;
                    seek(f,c2); write(f,b); t:=t+1;
                    seek(f,0); read(f,b); b.num:=b.num+1; seek(f,0); write(f,b);
                  end else print('Illegal filename.');
                end;
              end;
            end;
      end;
    until exit or hangup;
  close(f);
  nl;nl;
end;


function ffile(x:str):str;
var r:regs; x1:str;
begin
  x:=align(x); x1:=copy(x,1,8)+copy(x,10,3);
  fat:= #255#0#0#0#0#0#0#0+x1+#0#0#0#0+'                     ';
  dta := #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0+
               #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0;
  r.ds := seg(dta);
  r.dx := ofs(dta)+1;
  r.ax := $1a00;
  msdos(r);
  r.ds := seg(fat);
  r.dx := ofs(fat)+1;
  r.ax := $1100;
  msdos(r);
  if r.ax=$1100 then x1:=copy(dta,9,8)+'.'+copy(dta,17,3) else x1:='';
  ffile:=x1;
end;

function nfile:str;
var x1:str; r:regs;
begin
  r.ax:=$1200;
  r.ds := seg(fat);
  r.dx := ofs(fat)+1;
  msdos(r);
  if r.ax=$1200 then x1:=copy(dta,9,8)+'.'+copy(dta,17,3) else x1:='';
  nfile:=x1;
end;

procedure dir(cd,x:str; all:boolean);
var
  abort,next:boolean;
  x1:str;
begin
  if cd<>'.' then chdir(cd);
  x1:=ffile(x);
  nl; abort:=false;
  while (x1<>'') and not abort do begin
    if ((copy(x1,10,3)='MSG') or (copy(x1,10,3)='TXT') or all) and okfile(x1) then
      printacr(x1,abort,next);
    x1:=nfile;
  end;
  if cd<>'.' then chdir('..');
end;

procedure copyfile(srcname,destname:str);
    var
      srcbuffer, destbuffer: array[1..16384] of byte;
      srcstatus, deststatus: record recoff, maxbuf: integer; end;
      eof_src: boolean;
      bite: byte;
      src, dest: file;

  procedure read_in(var b: byte);
    begin
      with srcstatus do begin
        recoff:=recoff+1;
        if recoff > maxbuf then begin
          blockread(src,srcbuffer,16384,maxbuf);
          recoff:=1;
        end;
        b:=srcbuffer[recoff];
        if maxbuf=0 then eof_src:=true;
      end;
    end;

  procedure write_out(var b:byte);
    begin
      with deststatus do begin
        recoff:=recoff+1;
        if recoff>16384 then begin
          blockwrite(dest,destbuffer,16384,maxbuf);
          recoff:=1;
        end;
        destbuffer[recoff]:=b;
      end;
    end;

  begin
    assign(src,srcname); reset(src,1);
    srcstatus.recoff:=16384; srcstatus.maxbuf:=16384;
    assign(dest,destname); rewrite(dest,1);
    deststatus.recoff := 0; eof_src := false;
    nl; print('Copying...');
    while not eof_src do begin
      read_in(bite);
      write_out(bite);
    end;
    if deststatus.recoff>0 then
      BlockWrite(Dest,DestBuffer,deststatus.recoff-1,deststatus.maxbuf);
    close(src); close(dest);
  end;


procedure ren;
begin
  fix(i[2]); fix(i[3]); abort:=false; nl;
  if (i[2]='') or (i[3]='') then begin abort:=true; print('Illegal filename.'); end;
  if not abort then begin
    assign(f,i[2]); {$I-} reset(f); {$I+}
    if ioresult=0 then begin
      close(f); assign(f,i[3]); {$I-} reset(f); {$I+}
      if ioresult<>0 then begin
        {$I-} rewrite(f); {$I+}
        if ioresult=0 then begin
          close(f); erase(f); assign(f,i[2]); rename(f,i[3]);
          print('Renamed.');
        end else print('Illegal filename.');
      end else begin close(f); print('Filename already in use.'); end;
    end else print('File not found.');
  end;
end;

procedure delfil;
begin
  nl;
  fix(i[2]);
  if (not so) and (pos('.TXT',i[2])=0) then begin
    i[2]:='';
  end;
  if i[2]<>'' then begin
    assign(f,i[2]);
    {$I-} erase(f); {$I+}
    if ioresult=0 then print('Deleted.') else print('File not found.');
  end else print('Illegal filename.');
end;

procedure copyf;
begin
  fix(i[2]); fix(i[3]); nl;
  if (pos('????????.???',i[3])<>0) then begin
    s1:=copy(i[3],1,pos('\',i[3])-1);
    s2:=copy(i[2],pos('\',i[2])+1,12);
    i[3]:=s1+'\'+s2;
  end;
  if (i[2]='') or (i[3]='') then print('Illegal filename.') else begin
    assign(f,i[2]); assign(f1,i[3]);
    {$I-} reset(f); {$I+}
    if ioresult<>0 then print('File not found.') else begin
      close(f);
      {$I-} reset(f1); {$I+}
      if ioresult=0 then begin
        print('File already exists.');
        close(f1);
      end else begin
        {$I-} rewrite(f1); {$I+}
        if ioresult<>0 then begin close(f); print('Illegal filename.'); end else begin
          close(f1);
          copyfile(i[2],i[3]);
        end;
      end;
    end;
  end;
end;

procedure dirf;
begin
  all:=false;
  if not (vdir(i[2]) or (i[2]='')) and so then all:=true;
  fix(i[2]);
  c1:=pos('\',i[2]);
  s1:=copy(i[2],1,c1-1);
  s2:=copy(i[2],c1+1,12);
  if s1='' then s1:=cd;
  nl; dir(s1,s2,all);
end;

procedure typef;
begin
  nl;
  fix(i[2]);
  if i[2]<>'' then printfile(i[2]) else print('Illegal filename.');
end;

procedure loadhelp;
var f:file; ch1:char; a,b,c:integer;
begin
  assign(f,'gfiles\help.msg');
  for ch1:='0' to '^' do helpi[ch1]:=0;
  {$I-} reset(f,1); {$I+}
  if ioresult=0 then begin
    blockread(f,help[1],25000,a);
    close(f);
    b:=1;
    while (b<a) do begin
      if help[b]='|' then begin
        ch1:=help[b+1];
        if ch1 in ['0'..'^'] then begin
          c:=b;
          while (help[c]<>#10) and (abs(c-b)<80) do c:=c+1;
          c:=c+1;
          if c<a then helpi[ch1]:=c;
        end;
      end;
      b:=b+1;
    end;
    help[a+1]:='|';
    print('Help file loaded.');
  end else print('No help file present.');
  nl;
end;


procedure dosfc;
begin
  nl; prompt(cd+': ');
  input(i1,35); parse(i1);
  if i[1]='?' then begin
    nl; nl; printfile('gfiles\dosmnu.msg');
  end;
  if i[1]='EDIT' then tedit;
  if i[1]='VOTEPRINT' then voteprint;
  if i[1]='LOADHELP' then loadhelp;
  if i[1]='GFILE' then gfileedit;
  if i[1]='QUIT' then donedos:=true;
  if i[1]='DEL' then delfil;
  if i[1]='TYPE' then typef;
  if i[1]='REN' then ren;
  if i[1]='DIR' then dirf;
  if i[1]='CD' then if vdir(i[2]) then cd:=i[2];
  if i[1]='COPY' then copyf;
end;

begin
  iport; cd:='GFILES';
  topheap:=ptr(seg(lastvar),ofs(lastvar));
  release(topheap);
  case upcase(cmd) of
    'D':begin
          donedos:=false;
          print('Now in Mini-DOS.  "?" for help');
          print('Only .TXT or .MSG files can be accessed.'); nl; nl;
          while (not hangup) and (not donedos) do
            dosfc;
        end;
    'T':term;
    'G':gfileedit;
    'E':begin
          prompt('Filename: ');
          input(i[2],12);
          tedit;
        end;
  end;
  return;
end.