Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/DATABASE.PAS

Pascal/Delphi Source File | 1988-02-13 | 14KB | 620 lines

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

unit database;

interface

uses gentypes,gensubs,subs1,subs2,overret1;

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 ('Sorry, must be from ',r1,' to ',r2,'.')
    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 ('Create first database now? *');
  if not yes then exit;
  makenewbase
end;

procedure openddfile;
begin
  assign (ddfile,'DataDir');
  reset (ddfile);
  if ioresult<>0
    then nobases
    else begin
      reset (ddfile);
      if filesize (ddfile)=0 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,'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 a:anystr);
var p:parsedentry;
begin
  parseentry (a,p);
  showparsedentry (p)
end;

procedure showentrynum (var a:anystr; num:integer);
begin
  writeln (^M,num,':');
  showentry (a)
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 e:entryrec);
var p:parsedentry;
    c:integer;
    done:boolean;
begin
  parseentry (e.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,e.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
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'Entry to '+txt+' [?=list]:');
    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 deletedata;
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)
end;

procedure listbases;
var cnt:integer;
    b:baserec;
begin
  writehdr ('List of Databases');
  if break then exit;
  for cnt:=1 to filesize (ddfile) do begin
    seek (ddfile,cnt-1);
    read (ddfile,b);
    if b.level<=ulvl then writeln (cnt,'. ',b.basename);
    if break then exit
  end
end;

procedure selectdata;
var n:integer;
    b:baserec;
begin
  if length(input)>1 then input:=copy(input,2,255) else
    repeat
      writestr ('Database number [?=list]:');
      if length(input)=0 then exit;
      if input='?' then begin
        listbases;
        input:=''
      end
    until length(input)>0;
  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)+'? *');
    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 pattern:');
  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
  writehdr ('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'Scanning ',curbase.basename,^M);
      newscan;
      if aborted then exit
    end;
    curbasenum:=curbasenum+1
  end;
  curbasenum:=1;
  openefile;
  writeln (^B'Newscan complete!')
end;

procedure killdatabase;
var b:baserec;
    cnt:integer;
begin
  writestr ('Kill database:  Are you sure? *');
  if not yes then exit;
  writecurbase;
  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,'Database.'+strr(cnt+1));
    rename (efile,'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 reorderdata;
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 database: ',numd);
  for curd:=0 to numd-2 do begin
    repeat
      writestr ('New database #'+strr(curd+1)+' [?=List, CR to 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:='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 renamedata;
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 setlevel;
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:deletedata;
      4:setlevel;
      5:killdatabase;
      6:reorderdata;
      7:renamedata
    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;

  repeat
    writeln (^B^M'Active:  '^S,curbase.basename);
    writeln ('Entries: '^S,curbase.numents);
    q:=menu('Database','DATA','QA*SLVNH%@CD');
    case q of
      2:adddata;
      3:selectdata;
      4:searchdata;
      5:listdata;
      6:newscan;
      7:newscanall;
      8:help ('Database.hlp');
      9:sysopcommands;
      10:changedata;
      11:deletedata
    end
  until hungupon or (q=1) or (filesize(ddfile)=0);
  close (ddfile);
  close (efile)
end;

begin
end.