Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/DATABASE.PAS

Pascal/Delphi Source File | 1991-04-13 | 16.7 KB | 670 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }

unit database;

interface

uses gentypes,configrt,gensubs,subs1,subs2,overret1,statret,userret,modem;

procedure datamenu;

implementation

procedure datamenu;
var curbase:baserec;
    curbasenum:integer;

procedure packentry (var p:parsedentry; var a:anystr);
var cnt:integer;
begin
  a:='';
  for cnt:=1 to curbase.numcats do
    if length(a)+length(p[cnt])>254 then begin
      writeln ('Entry to big, truncated.');
      exit
    end else a:=a+p[cnt]+#1
end;

procedure parseentry (var oa:anystr; var p:parsedentry);
var d,cnt:integer;
    a:anystr;
begin
  a:=oa;
  for cnt:=1 to curbase.numcats do begin
    d:=pos(#1,a);
    if d=0 then p[cnt]:=''
     else begin
        p[cnt]:=copy(a,1,d-1);
        a:=copy(a,d+1,255)
     end
  end
end;

procedure makenewbase;

  function getnumber (r1,r2:integer; txt:mstr):integer;
  var t:integer;
  begin
    repeat
      writestr (txt+':');
      t:=valu(input);
      if (t<r1) or (t>r2) then
        writeln (^R'Sorry, must be from '^S,r1,^R' to '^S,r2,^R'.')
    until (t>=r1) and (t<=r2);
    getnumber:=t
  end;

var n,cnt:integer;
    b:baserec;
    p:parsedentry;
begin
  n:=filesize(ddfile)+1;
  writehdr ('Create Database Number '+strr(n));
  writestr ('Database Name:');
  if length(input)=0 then exit;
  b.basename:=input;
  writestr ('Access Level:');
  if length(input)=0
    then b.level:=1
    else b.level:=valu(input);
  b.numcats:=getnumber (1,maxcats,'Number of categories');
  b.numents:=0;
  for cnt:=1 to b.numcats do begin
    writestr ('Category #'+strr(cnt)+' Name:');
    if length(input)=0 then exit;
    p[cnt]:=input
  end;
  curbase:=b;
  packentry (p,b.catnames);
  seek (ddfile,n-1);
  write (ddfile,b);
  writeln ('Database created!');
  writelog (7,2,b.basename);
  curbase:=b;
  curbasenum:=n
end;

procedure nobases;
begin
  rewrite (ddfile);
  writeln ('No Databases exist!');
  if not issysop then exit;
  writestr (^R'Create first Database now? ['^P'y/N'^R']: *');
  if not yes then exit;
  makenewbase
end;

procedure openddfile;
begin
  assign (ddfile,bbsdatadir+'DataDir.dat');
  reset (ddfile);
  if ioresult<>0
    then nobases
    else begin
      reset (ddfile);
      if filesize (ddfile)<1 then begin
        close (ddfile);
        nobases
      end
    end
end;

procedure writecurbase;
begin
  seek (ddfile,curbasenum-1);
  write (ddfile,curbase)
end;

procedure readcurbase;
begin
  seek (ddfile,curbasenum-1);
  read (ddfile,curbase)
end;

procedure openefile;
var i:integer;
begin
  readcurbase;
  if isopen(efile) then close(efile);
  i:=ioresult;
  assign (efile,bbsdatadir+'DataBase.'+strr(curbasenum));
  reset (efile);
  if ioresult<>0 then rewrite (efile);
  curbase.numents:=filesize(efile);
  writecurbase
end;

function getparsedentry (var p:parsedentry):boolean;
var cnt:integer;
    pr:parsedentry;
    nonblank:boolean;
begin
  nonblank:=false;
  parseentry (curbase.catnames,pr);
  writeln ('(*=',unam,')');
  for cnt:=1 to curbase.numcats do begin
    writestr (pr[cnt]+': &');
    if length(input)>0 then nonblank:=true;
    if input='*'
      then p[cnt]:=unam
      else p[cnt]:=input
  end;
  getparsedentry:=nonblank
end;

function getentry (var a:anystr):boolean;
var p:parsedentry;
begin
  getentry:=getparsedentry (p);
  packentry (p,a)
end;

const shownumbers:boolean=false;
procedure showparsedentry (var p:parsedentry);
var cnt:integer;
    pr:parsedentry;
begin
  parseentry (curbase.catnames,pr);
  for cnt:=1 to curbase.numcats do begin
    if shownumbers then write (cnt,'. ');
    writeln (pr[cnt],': '^S,p[cnt]);
    if break then exit
  end;
  shownumbers:=false
end;

procedure showentry (var b:anystr);
var p:parsedentry;
begin
  parseentry (b,p);
  showparsedentry (p)
end;

procedure showentrynum (var art:anystr; n:integer);
begin
  writeln (^M^R,'Entry '^S,n,^R' of '^S,curbase.numents,^R);
  showentry (art)
end;

function noentries:boolean;
begin
  if curbase.numents>0 then noentries:=false
   else begin
     writeln ('Sorry, Database is empty!');
     noentries:=true
   end
end;

procedure changeentryrec (var s:entryrec);
var p:parsedentry;
    c:integer;
    done:boolean;
begin
  parseentry (s.data,p);
  repeat
    shownumbers:=true;
    showparsedentry (p);
    writestr (^M'Category number to change [CR to exit]:');
    done:=length(input)=0;
    if not done then begin
      c:=valu(input);
      if (c>0) and (c<=curbase.numcats) then begin
        writestr ('New value [*=Your name, CR to leave unchanged]: &');
        if length(input)<>0 then if input='*'
         then p[c]:=unam
         else p[c]:=input
      end
    end
  until done;
  packentry (p,s.data)
end;

procedure adddata;
var e:entryrec;
begin
  writehdr ('Add an entry');
  if not getentry (e.data) then begin
    writeln ('- Blank Entry! -');
    exit
  end;
  writestr (^M'Make changes? [Y/N/X]: *');
  if length(input)<>0 then
    case upcase(input[1]) of
      'X':begin
            writestr ('Entry not added.');
            exit
          end;
      'Y':changeentryrec (e)
    end;
  e.when:=now;
  e.addedby:=unum;
  seek (efile,curbase.numents);
  write (efile,e);
  curbase.numents:=curbase.numents+1;
  writecurbase;
  if dbases>32760 then dbases:=0;
  dbases:=dbases+1
end;

procedure listdata;
var cnt,f,l:integer;
    e:entryrec;
begin
  if noentries then exit;
  writeln;
  parserange (curbase.numents,f,l);
  if f=0 then exit;
  writeln;
  for cnt:=f to l do begin
    seek (efile,cnt-1);
    read (efile,e);
    showentrynum (e.data,cnt);
    if break then exit
  end
end;

function getdatanum (txt:mstr):integer;
var n:integer;
begin
  getdatanum:=0;
  if noentries then exit;
  repeat
    writestr (^M^R'Entry to '^S+txt+^R' ['^S'?/List'^R']:');
    if length(input)=0 then exit;
    if input='?' then begin
      listdata;
      input:=''
    end
  until length(input)>0;
  n:=valu(input);
  if (n>0) and (n<=curbase.numents) then getdatanum:=n
end;

function notuseradded (var e:entryrec):boolean;
var b:boolean;
begin
  b:=not ((e.addedby=unum) or issysop);
  notuseradded:=b;
  if b then writestr ('You didn''t add this entry!')
end;

procedure changedata;
var n:integer;
    e:entryrec;
begin
  n:=getdatanum ('change');
  if n=0 then exit;
  seek (efile,n-1);
  read (efile,e);
  if notuseradded (e) then exit;
  writelog (8,3,copy(e.data,1,pos(#1,e.data)-1));
  changeentryrec (e);
  seek (efile,n-1);
  write (efile,e)
end;

procedure deleteit;
var n,cnt:integer;
    e:entryrec;
    p:parsedentry;
begin
  n:=getdatanum ('Delete');
  if n=0 then exit;
  seek (efile,n-1);
  read (efile,e);
  if notuseradded(e) then exit;
  parseentry (e.data,p);
  writelog (8,6,p[1]);
  curbase.numents:=curbase.numents-1;
  writecurbase;
  for cnt:=n to curbase.numents do begin
    seek (efile,cnt);
    read (efile,e);
    seek (efile,cnt-1);
    write (efile,e)
  end;
  seek (efile,curbase.numents);
  truncate (efile);
  if dbases<1 then dbases:=1;
  dbases:=dbases-1;
  if urec.lastdbases<1 then urec.lastdbases:=1;
  urec.lastdbases:=urec.lastdbases-1
end;

procedure listbases;
var cnt:integer;
    b:baserec;
begin
  if break then exit;
  writeln (^B^R'[##] [Name]'^M);
  for cnt:=1 to filesize (ddfile) do begin
    seek (ddfile,cnt-1);
    read (ddfile,b);
    if b.level<=ulvl then begin
     write (^P'['^S);
     tab (strr(cnt),2);
     write (^P'] ['^S);
     tab (b.basename,30);
     writeln (^P']'^R)
    end;
    if break then exit
  end;
  writeln;
end;

procedure selectdata;
var n:integer;
    b:baserec;
begin
  if length(input)>1 then input:=copy(input,2,255) else
   begin
    listbases;
    repeat
      writestr ('Database Number ['^S'?/List'^P']:');
      if length(input)<1 then exit;
      if input='?' then begin
        listbases;
        input:=''
      end
    until length(input)>0
   end;
  n:=valu(input);
  if (n<1) or (n>filesize(ddfile)) then begin
    writeln ('No such Database: '^S,n);
    if not issysop then exit;
    n:=filesize(ddfile)+1;
    writestr ('Create Database #'+strr(n)+'? [y/n]: *');
    if yes then begin
      writecurbase;
      makenewbase;
      openefile
    end;
    exit
  end;
  seek (ddfile,n-1);
  read (ddfile,b);
  if b.level>ulvl then begin
    reqlevel (b.level);
    exit
  end;
  writecurbase;
  curbasenum:=n;
  openefile
end;

procedure searchdata;
var cnt,f,en:integer;
    e:entryrec;
    pattern:anystr;
    p:parsedentry;
begin
  if noentries then exit;
  writestr ('Search for:');
  if length(input)=0 then exit;
  pattern:=input;
  for cnt:=1 to length(pattern) do pattern[cnt]:=upcase(pattern[cnt]);
  for en:=1 to curbase.numents do begin
    seek (efile,en-1);
    read (efile,e);
    parseentry (e.data,p);
    for f:=1 to curbase.numcats do begin
      for cnt:=1 to length(p[f]) do p[f][cnt]:=upcase(p[f][cnt]);
      if pos(pattern,p[f])<>0 then showentrynum (e.data,en)
    end
  end;
  writeln (^M'Search complete.')
end;

const beenaborted:boolean=false;

function aborted:boolean;
begin
  if beenaborted then begin
    aborted:=true;
    exit
  end;
  aborted:=xpressed or hungupon;
  if xpressed then begin
    beenaborted:=true;
    writeln (^B'Newscan aborted!')
  end
end;

procedure newscan;
var first,cnt:integer;
    nd:boolean;
    e:entryrec;
begin
  beenaborted:=false;
  first:=curbase.numents;
  nd:=true;
  while (first>0) and nd do begin
    seek (efile,first-1);
    read (efile,e);
    nd:=e.when>laston;
    if nd then first:=first-1
  end;
  for cnt:=first+1 to curbase.numents do begin
    seek (efile,cnt-1);
    read (efile,e);
    if aborted then exit;
    showentrynum (e.data,cnt)
  end
end;

procedure newscanall;
begin
  writeln (^M^R'Scanning since last on as of: ['^S,datestr(laston),^R']'^M);
  writeln ('New-Scanning - Press [X] to Abort.');
  curbasenum:=1;
  while curbasenum<=filesize(ddfile) do begin
    if aborted then exit;
    openefile;
    if curbase.level<=ulvl then begin
      writeln (^B^M^R'Scanning ['^S,curbase.basename,^R']'^M);
      newscan;
      if aborted then exit
    end;
    curbasenum:=curbasenum+1
  end;
  curbasenum:=1;
  openefile;
  writeln (^B'Newscan complete!')
end;

procedure l8r;
var b:baserec;
    cnt:integer;
begin
  writestr ('Kill Database - Are you sure? [y/N]: *');
  if not yes then exit;
  writecurbase;
  dbases:=dbases-curbase.numents;
  if dbases<1 then dbases:=1;
  urec.lastdbases:=urec.lastdbases-curbase.numents;
  if urec.lastdbases<1 then urec.lastdbases:=1;
  writeurec;
  close (efile);
  erase (efile);
  for cnt:=curbasenum to filesize(ddfile)-1 do begin
    seek (ddfile,cnt);
    read (ddfile,b);
    seek (ddfile,cnt-1);
    write (ddfile,b);
    assign (efile,bbsdatadir+'Database.'+strr(cnt+1));
    rename (efile,bbsdatadir+'Database.'+strr(cnt))
  end;
  seek (ddfile,filesize(ddfile)-1);
  truncate (ddfile);
  writelog (8,5,'');
  if filesize(ddfile)>0 then begin
    curbasenum:=1;
    openefile
  end
end;

procedure datareorder;
var numd,curd,newd:integer;
    b1,b2:baserec;
    f1,f2:file;
    fn1,fn2:sstr;
label exit;
begin
  writecurbase;
  writehdr ('Re-order Databases');
  writelog (8,1,'');
  numd:=filesize (ddfile);
  writeln ('Number of Databases: ',numd);
  for curd:=0 to numd-2 do begin
    repeat
      writestr ('New Database #'+strr(curd+1)+' [?/List, CR/Quit]:');
      if length(input)=0 then goto exit;
      if input='?' then begin
         listbases;
         newd:=-1
      end else begin
         newd:=valu(input)-1;
         if (newd<0) or (newd>=numd) then begin
            writeln ('Not found!  Please re-enter...');
            newd:=-1
         end
      end
    until (newd>0);
    seek (ddfile,curd);
    read (ddfile,b1);
    seek (ddfile,newd);
    read (ddfile,b2);
    seek (ddfile,curd);
    write (ddfile,b2);
    seek (ddfile,newd);
    write (ddfile,b1);
    fn1:=bbsdatadir+'Database.';
    fn2:=fn1+strr(newd+1);
    fn1:=fn1+strr(curd+1);
    assign (f1,fn1);
    assign (f2,fn2);
    rename (f1,'Temp$$$$');
    rename (f2,fn1);
    rename (f1,fn2)
  end;
  exit:
  curbasenum:=1;
  openefile
end;

procedure renamebase;
begin
  writeln ('Current name: '^S,curbase.basename);
  writestr ('Enter new name:');
  if length(input)>0 then begin
    curbase.basename:=input;
    writecurbase;
    writelog (8,2,input)
  end
end;

procedure levelset;
begin
  writeln ('Current Level: '^S,curbase.level);
  writestr ('Enter new Level:');
  if length(input)>0 then begin
    curbase.level:=valu(input);
    writecurbase;
    writelog (8,4,strr(curbase.level))
  end
end;

procedure sysopcommands;
var q:integer;
begin
  writelog (7,1,curbase.basename);
  repeat
    q:=menu ('Database Sysop','DSYSOP','QCDEKOR?');
    case q of
      2:changedata;
      3:deleteit;
      4:levelset;
      5:l8r;
      6:datareorder;
      7:renamebase;
      8:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Database Sysop Section              ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [C] s');
writeln ('uChange Data File                ║HC║ [Ds');
writeln ('u] Delete Data File                ║HC║ [s');
writeln ('uE] Set Levels                      ║Hs');
writeln ('uC║ [K] Kill Database                   s');
writeln ('u║HC║ [O] Re-Order Databases       s');
writeln ('u       ║HC║ [Q] Quit              s');
writeln ('u              ║HC║ [R] Rename Datas');
writeln ('ubase                 ║HC║ [?] Views');
writeln ('u This Menu                  ║HC╚═════════════════A');
writeln ('C════════════════════╝');
writeln;
pause;
           end;
    end
  until (q=1) or hungupon or (filesize(ddfile)=0)
end;

var q:integer;
begin
  cursection:=databasesysop;
  openddfile;
  if filesize(ddfile)=0 then exit;
  curbasenum:=1;
  seek (ddfile,0);
  read (ddfile,curbase);
  if curbase.level>ulvl then begin
    reqlevel (curbase.level);
    close (ddfile);
    exit
  end;
  openefile;
  writehdr ('Databases');
  repeat
    writeln (^B^M'Active: ['^S,curbase.basename,^R']');
    writeln ('Entries: '^S,curbase.numents);
    q:=menu('Database','DBASE','QA*SLVN%@CD?');
    case q of
      2:adddata;
      3:selectdata;
      4:searchdata;
      5:listdata;
      6:newscan;
      7:newscanall;
      8:sysopcommands;
      9:changedata;
      10:deleteit;
      11:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Database Section                    ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A] s');
writeln ('uAdd Database File               ║HC║ [Cs');
writeln ('u] Change Database File            ║HC║ [s');
writeln ('uD] Delete Database File            ║Hs');
writeln ('uC║ [L] List Database File(s)           s');
writeln ('u║HC║ [N] Newscan all Databases    s');
writeln ('u       ║HC║ [Q] Quit              s');
writeln ('u              ║HC║ [S] Search Datas');
writeln ('ubases                ║HC║ [V] Newss');
writeln ('ucan Current Database        ║HC║ [%] s');
writeln ('uDatabase Sysop Section          ║HC║ [*s');
writeln ('u] Change Active Database          ║HC║ s');
writeln ('u[?] View This Menu                  ║HA');
writeln ('C╚═════════════════════════════════════╝');
writeln;
pause;
         end;
    end
  until hungupon or (q=1) or (filesize(ddfile)=0);
  close (ddfile);
  close (efile)
end;

begin
end.