Jason Aller Floppy Collection/270.img/FORUM25C.ZIP/DATABASE.PAS

Pascal/Delphi Source File | 1988-12-27 | 14KB | 628 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

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;

end.