home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 189.img / TCS120S.ZIP / DATABASE.PAS < prev    next >
Pascal/Delphi Source File  |  1989-03-20  |  14KB  |  640 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit database;
  5.  
  6. interface
  7.  
  8. uses gentypes,gensubs,subs1,subs2,overret1,statret,userret;
  9.  
  10. procedure datamenu;
  11.  
  12. implementation
  13.  
  14. procedure datamenu;
  15. var curbase:baserec;
  16.     curbasenum:integer;
  17.  
  18. procedure packentry (var p:parsedentry; var a:anystr);
  19. var cnt:integer;
  20. begin
  21.   a:='';
  22.   for cnt:=1 to curbase.numcats do
  23.     if length(a)+length(p[cnt])>254 then begin
  24.       writeln ('Entry to big, truncated.');
  25.       exit
  26.     end else a:=a+p[cnt]+#1
  27. end;
  28.  
  29. procedure parseentry (var oa:anystr; var p:parsedentry);
  30. var d,cnt:integer;
  31.     a:anystr;
  32. begin
  33.   a:=oa;
  34.   for cnt:=1 to curbase.numcats do begin
  35.     d:=pos(#1,a);
  36.     if d=0
  37.       then p[cnt]:=''
  38.       else
  39.         begin
  40.           p[cnt]:=copy(a,1,d-1);
  41.           a:=copy(a,d+1,255)
  42.         end
  43.   end
  44. end;
  45.  
  46. procedure makenewbase;
  47.  
  48.   function getnumber (r1,r2:integer; txt:mstr):integer;
  49.   var t:integer;
  50.   begin
  51.     repeat
  52.       writestr (txt+':');
  53.       t:=valu(input);
  54.       if (t<r1) or (t>r2) then
  55.         writeln ('Sorry, must be from ',r1,' to ',r2,'.')
  56.     until (t>=r1) and (t<=r2);
  57.     getnumber:=t
  58.   end;
  59.  
  60. var n,cnt:integer;
  61.     b:baserec;
  62.     p:parsedentry;
  63. begin
  64.   n:=filesize(ddfile)+1;
  65.   writehdr ('Create Database Number '+strr(n));
  66.   writestr ('Database Name:');
  67.   if length(input)=0 then exit;
  68.   b.basename:=input;
  69.   writestr ('Access Level:');
  70.   if length(input)=0
  71.     then b.level:=1
  72.     else b.level:=valu(input);
  73.   b.numcats:=getnumber (1,maxcats,'Number of categories');
  74.   b.numents:=0;
  75.   for cnt:=1 to b.numcats do begin
  76.     writestr ('Category #'+strr(cnt)+' Name:');
  77.     if length(input)=0 then exit;
  78.     p[cnt]:=input
  79.   end;
  80.   curbase:=b;
  81.   packentry (p,b.catnames);
  82.   seek (ddfile,n-1);
  83.   write (ddfile,b);
  84.   writeln ('Database created!');
  85.   writelog (7,2,b.basename);
  86.   curbase:=b;
  87.   curbasenum:=n
  88. end;
  89.  
  90. procedure nobases;
  91. begin
  92.   rewrite (ddfile);
  93.   writeln ('No Databases exist!');
  94.   if not issysop then exit;
  95.   writestr ('Create first Database now [y/n]? *');
  96.   if not yes then exit;
  97.   makenewbase
  98. end;
  99.  
  100. procedure openddfile;
  101. begin
  102.   assign (ddfile,'DataDir');
  103.   reset (ddfile);
  104.   if ioresult<>0
  105.     then nobases
  106.     else begin
  107.       reset (ddfile);
  108.       if filesize (ddfile)=0 then begin
  109.         close (ddfile);
  110.         nobases
  111.       end
  112.     end
  113. end;
  114.  
  115. procedure writecurbase;
  116. begin
  117.   seek (ddfile,curbasenum-1);
  118.   write (ddfile,curbase)
  119. end;
  120.  
  121. procedure readcurbase;
  122. begin
  123.   seek (ddfile,curbasenum-1);
  124.   read (ddfile,curbase)
  125. end;
  126.  
  127. procedure openefile;
  128. var i:integer;
  129. begin
  130.   readcurbase;
  131.   if isopen(efile) then close(efile);
  132.   i:=ioresult;
  133.   assign (efile,'Database.'+strr(curbasenum));
  134.   reset (efile);
  135.   if ioresult<>0 then rewrite (efile);
  136.   curbase.numents:=filesize(efile);
  137.   writecurbase
  138. end;
  139.  
  140. function getparsedentry (var p:parsedentry):boolean;
  141. var cnt:integer;
  142.     pr:parsedentry;
  143.     nonblank:boolean;
  144. begin
  145.   nonblank:=false;
  146.   parseentry (curbase.catnames,pr);
  147.   writeln ('(*=',unam,')');
  148.   for cnt:=1 to curbase.numcats do begin
  149.     writestr (pr[cnt]+': &');
  150.     if length(input)>0 then nonblank:=true;
  151.     if input='*'
  152.       then p[cnt]:=unam
  153.       else p[cnt]:=input
  154.   end;
  155.   getparsedentry:=nonblank
  156. end;
  157.  
  158. function getentry (var a:anystr):boolean;
  159. var p:parsedentry;
  160. begin
  161.   getentry:=getparsedentry (p);
  162.   packentry (p,a)
  163. end;
  164.  
  165. const shownumbers:boolean=false;
  166. procedure showparsedentry (var p:parsedentry);
  167. var cnt:integer;
  168.     pr:parsedentry;
  169. begin
  170.   parseentry (curbase.catnames,pr);
  171.   for cnt:=1 to curbase.numcats do begin
  172.     if shownumbers then write (cnt,'. ');
  173.     writeln (pr[cnt],': '^S,p[cnt]);
  174.     if break then exit
  175.   end;
  176.   shownumbers:=false
  177. end;
  178.  
  179. procedure showentry (var a:anystr);
  180. var p:parsedentry;
  181. begin
  182.   parseentry (a,p);
  183.   showparsedentry (p)
  184. end;
  185.  
  186. procedure showentrynum (var a:anystr; num:integer);
  187. begin
  188.   writeln (^M^R,'Entry '^S,num,^R' of '^S,curbase.numents,^R);
  189.   showentry (a)
  190. end;
  191.  
  192. function noentries:boolean;
  193. begin
  194.   if curbase.numents>0
  195.     then noentries:=false
  196.     else
  197.       begin
  198.         writeln ('Sorry, Database is empty!');
  199.         noentries:=true
  200.       end
  201. end;
  202.  
  203. procedure changeentryrec (var e:entryrec);
  204. var p:parsedentry;
  205.     c:integer;
  206.     done:boolean;
  207. begin
  208.   parseentry (e.data,p);
  209.   repeat
  210.     shownumbers:=true;
  211.     showparsedentry (p);
  212.     writestr (^M'Category number to change [CR to exit]:');
  213.     done:=length(input)=0;
  214.     if not done then begin
  215.       c:=valu(input);
  216.       if (c>0) and (c<=curbase.numcats) then begin
  217.         writestr ('New value [*=Your name, CR to leave unchanged]: &');
  218.         if length(input)<>0 then
  219.           if input='*'
  220.             then p[c]:=unam
  221.             else p[c]:=input
  222.       end
  223.     end
  224.   until done;
  225.   packentry (p,e.data)
  226. end;
  227.  
  228. procedure adddata;
  229. var e:entryrec;
  230. begin
  231.   writehdr ('Add an entry');
  232.   if not getentry (e.data) then begin
  233.     writeln ('Blank entry!');
  234.     exit
  235.   end;
  236.   writestr (^M'Make changes (Y/N/X)? *');
  237.   if length(input)<>0 then
  238.     case upcase(input[1]) of
  239.       'X':begin
  240.             writestr ('Entry not added.');
  241.             exit
  242.           end;
  243.       'Y':changeentryrec (e)
  244.     end;
  245.   e.when:=now;
  246.   e.addedby:=unum;
  247.   seek (efile,curbase.numents);
  248.   write (efile,e);
  249.   curbase.numents:=curbase.numents+1;
  250.   writecurbase;
  251.   if dbases>32760 then dbases:=0;
  252.   dbases:=dbases+1
  253. end;
  254.  
  255. procedure listdata;
  256. var cnt,f,l:integer;
  257.     e:entryrec;
  258. begin
  259.   if noentries then exit;
  260.   writeln;
  261.   parserange (curbase.numents,f,l);
  262.   if f=0 then exit;
  263.   writeln;
  264.   for cnt:=f to l do begin
  265.     seek (efile,cnt-1);
  266.     read (efile,e);
  267.     showentrynum (e.data,cnt);
  268.     if break then exit
  269.   end
  270. end;
  271.  
  272. function getdatanum (txt:mstr):integer;
  273. var n:integer;
  274. begin
  275.   getdatanum:=0;
  276.   if noentries then exit;
  277.   repeat
  278.     writestr (^M'Entry to '+txt+' [?/List]:');
  279.     if length(input)=0 then exit;
  280.     if input='?' then begin
  281.       listdata;
  282.       input:=''
  283.     end
  284.   until length(input)>0;
  285.   n:=valu(input);
  286.   if (n>0) and (n<=curbase.numents) then getdatanum:=n
  287. end;
  288.  
  289. function notuseradded (var e:entryrec):boolean;
  290. var b:boolean;
  291. begin
  292.   b:=not ((e.addedby=unum) or issysop);
  293.   notuseradded:=b;
  294.   if b then writestr ('You didn''t add this entry!')
  295. end;
  296.  
  297. procedure changedata;
  298. var n:integer;
  299.     e:entryrec;
  300. begin
  301.   n:=getdatanum ('change');
  302.   if n=0 then exit;
  303.   seek (efile,n-1);
  304.   read (efile,e);
  305.   if notuseradded (e) then exit;
  306.   writelog (8,3,copy(e.data,1,pos(#1,e.data)-1));
  307.   changeentryrec (e);
  308.   seek (efile,n-1);
  309.   write (efile,e);
  310. end;
  311.  
  312. procedure deletedata;
  313. var n,cnt:integer;
  314.     e:entryrec;
  315.     p:parsedentry;
  316. begin
  317.   n:=getdatanum ('Delete');
  318.   if n=0 then exit;
  319.   seek (efile,n-1);
  320.   read (efile,e);
  321.   if notuseradded(e) then exit;
  322.   parseentry (e.data,p);
  323.   writelog (8,6,p[1]);
  324.   curbase.numents:=curbase.numents-1;
  325.   writecurbase;
  326.   for cnt:=n to curbase.numents do begin
  327.     seek (efile,cnt);
  328.     read (efile,e);
  329.     seek (efile,cnt-1);
  330.     write (efile,e)
  331.   end;
  332.   seek (efile,curbase.numents);
  333.   truncate (efile);
  334.   if dbases<1 then dbases:=1;
  335.   dbases:=dbases-1;
  336.   if urec.lastdbases<1 then urec.lastdbases:=1;
  337.   urec.lastdbases:=urec.lastdbases-1;
  338. end;
  339.  
  340. procedure listbases;
  341. var cnt:integer;
  342.     b:baserec;
  343. begin
  344.   if break then exit;
  345.   writeln (^B^R'[##] [Name]'^M);
  346.   for cnt:=1 to filesize (ddfile) do begin
  347.     seek (ddfile,cnt-1);
  348.     read (ddfile,b);
  349.     if b.level<=ulvl then begin
  350.      write (^R'['^S);
  351.      tab (strr(cnt),2);
  352.      write (^R'] ['^S);
  353.      tab (b.basename,30);
  354.      writeln (^R']');
  355.     end;
  356.     if break then exit
  357.   end;
  358.   writeln;
  359. end;
  360.  
  361. procedure selectdata;
  362. var n:integer;
  363.     b:baserec;
  364. begin
  365.   if length(input)>1 then input:=copy(input,2,255) else
  366.    begin
  367.     listbases;
  368.     repeat
  369.       writestr ('Database Number [?/List]:');
  370.       if length(input)=0 then exit;
  371.       if input='?' then begin
  372.         listbases;
  373.         input:=''
  374.       end
  375.     until length(input)>0;
  376.    end;
  377.   n:=valu(input);
  378.   if (n<1) or (n>filesize(ddfile)) then begin
  379.     writeln ('No such Database: '^S,n);
  380.     if not issysop then exit;
  381.     n:=filesize(ddfile)+1;
  382.     writestr ('Create Database #'+strr(n)+' [y/n]? *');
  383.     if yes then begin
  384.       writecurbase;
  385.       makenewbase;
  386.       openefile
  387.     end;
  388.     exit
  389.   end;
  390.   seek (ddfile,n-1);
  391.   read (ddfile,b);
  392.   if b.level>ulvl then begin
  393.     reqlevel (b.level);
  394.     exit
  395.   end;
  396.   writecurbase;
  397.   curbasenum:=n;
  398.   openefile
  399. end;
  400.  
  401. procedure searchdata;
  402. var cnt,f,en:integer;
  403.     e:entryrec;
  404.     pattern:anystr;
  405.     p:parsedentry;
  406. begin
  407.   if noentries then exit;
  408.   writestr ('Search for:');
  409.   if length(input)=0 then exit;
  410.   pattern:=input;
  411.   for cnt:=1 to length(pattern) do pattern[cnt]:=upcase(pattern[cnt]);
  412.   for en:=1 to curbase.numents do begin
  413.     seek (efile,en-1);
  414.     read (efile,e);
  415.     parseentry (e.data,p);
  416.     for f:=1 to curbase.numcats do begin
  417.       for cnt:=1 to length(p[f]) do p[f][cnt]:=upcase(p[f][cnt]);
  418.       if pos(pattern,p[f])<>0 then showentrynum (e.data,en)
  419.     end
  420.   end;
  421.   writeln (^M'Search complete.')
  422. end;
  423.  
  424. const beenaborted:boolean=false;
  425.  
  426. function aborted:boolean;
  427. begin
  428.   if beenaborted then begin
  429.     aborted:=true;
  430.     exit
  431.   end;
  432.   aborted:=xpressed or hungupon;
  433.   if xpressed then begin
  434.     beenaborted:=true;
  435.     writeln (^B'Newscan aborted!')
  436.   end
  437. end;
  438.  
  439. procedure newscan;
  440. var first,cnt:integer;
  441.     nd:boolean;
  442.     e:entryrec;
  443. begin
  444.   beenaborted:=false;
  445.   first:=curbase.numents;
  446.   nd:=true;
  447.   while (first>0) and nd do begin
  448.     seek (efile,first-1);
  449.     read (efile,e);
  450.     nd:=e.when>laston;
  451.     if nd then first:=first-1
  452.   end;
  453.   for cnt:=first+1 to curbase.numents do begin
  454.     seek (efile,cnt-1);
  455.     read (efile,e);
  456.     if aborted then exit;
  457.     showentrynum (e.data,cnt)
  458.   end
  459. end;
  460.  
  461. procedure newscanall;
  462. begin
  463.   writehdr ('New-Scanning - Press [X] to Abort.');
  464.   curbasenum:=1;
  465.   while curbasenum<=filesize(ddfile) do begin
  466.     if aborted then exit;
  467.     openefile;
  468.     if curbase.level<=ulvl then begin
  469.       writeln (^B^M^R'Scanning ['^S,curbase.basename,^R']'^M);
  470.       newscan;
  471.       if aborted then exit
  472.     end;
  473.     curbasenum:=curbasenum+1
  474.   end;
  475.   curbasenum:=1;
  476.   openefile;
  477.   writeln (^B'Newscan complete!')
  478. end;
  479.  
  480. procedure killdatabase;
  481. var b:baserec;
  482.     cnt:integer;
  483. begin
  484.   writestr ('Kill Database - Are you sure [y/n]? *');
  485.   if not yes then exit;
  486.   writecurbase;
  487.   dbases:=dbases-curbase.numents;
  488.   if dbases<1 then dbases:=1;
  489.   urec.lastdbases:=urec.lastdbases-curbase.numents;
  490.   if urec.lastdbases<1 then urec.lastdbases:=1;
  491.   writeurec;
  492.   close (efile);
  493.   erase (efile);
  494.   for cnt:=curbasenum to filesize(ddfile)-1 do begin
  495.     seek (ddfile,cnt);
  496.     read (ddfile,b);
  497.     seek (ddfile,cnt-1);
  498.     write (ddfile,b);
  499.     assign (efile,'Database.'+strr(cnt+1));
  500.     rename (efile,'Database.'+strr(cnt))
  501.   end;
  502.   seek (ddfile,filesize(ddfile)-1);
  503.   truncate (ddfile);
  504.   writelog (8,5,'');
  505.   if filesize(ddfile)>0 then begin
  506.     curbasenum:=1;
  507.     openefile
  508.   end
  509. end;
  510.  
  511. procedure reorderdata;
  512. var numd,curd,newd:integer;
  513.     b1,b2:baserec;
  514.     f1,f2:file;
  515.     fn1,fn2:sstr;
  516. label exit;
  517. begin
  518.   writecurbase;
  519.   writehdr ('Re-order Databases');
  520.   writelog (8,1,'');
  521.   numd:=filesize (ddfile);
  522.   writeln ('Number of Databases: ',numd);
  523.   for curd:=0 to numd-2 do begin
  524.     repeat
  525.       writestr ('New Database #'+strr(curd+1)+' [?/List, CR/Quit]:');
  526.       if length(input)=0 then goto exit;
  527.       if input='?'
  528.         then
  529.           begin
  530.             listbases;
  531.             newd:=-1
  532.           end
  533.         else
  534.           begin
  535.             newd:=valu(input)-1;
  536.             if (newd<0) or (newd>=numd) then begin
  537.               writeln ('Not found!  Please re-enter...');
  538.               newd:=-1
  539.             end
  540.           end
  541.     until (newd>0);
  542.     seek (ddfile,curd);
  543.     read (ddfile,b1);
  544.     seek (ddfile,newd);
  545.     read (ddfile,b2);
  546.     seek (ddfile,curd);
  547.     write (ddfile,b2);
  548.     seek (ddfile,newd);
  549.     write (ddfile,b1);
  550.     fn1:='Database.';
  551.     fn2:=fn1+strr(newd+1);
  552.     fn1:=fn1+strr(curd+1);
  553.     assign (f1,fn1);
  554.     assign (f2,fn2);
  555.     rename (f1,'Temp$$$$');
  556.     rename (f2,fn1);
  557.     rename (f1,fn2)
  558.   end;
  559.   exit:
  560.   curbasenum:=1;
  561.   openefile
  562. end;
  563.  
  564. procedure renamedata;
  565. begin
  566.   writeln ('Current name: '^S,curbase.basename);
  567.   writestr ('Enter new name:');
  568.   if length(input)>0 then begin
  569.     curbase.basename:=input;
  570.     writecurbase;
  571.     writelog (8,2,input)
  572.   end
  573. end;
  574.  
  575. procedure setlevel;
  576. begin
  577.   writeln ('Current Level: '^S,curbase.level);
  578.   writestr ('Enter new Level:');
  579.   if length(input)>0 then begin
  580.     curbase.level:=valu(input);
  581.     writecurbase;
  582.     writelog (8,4,strr(curbase.level))
  583.   end
  584. end;
  585.  
  586. procedure sysopcommands;
  587. var q:integer;
  588. begin
  589.   writelog (7,1,curbase.basename);
  590.   repeat
  591.     q:=menu('Database Sysop','DSYSOP','QCDEKOR');
  592.     case q of
  593.       2:changedata;
  594.       3:deletedata;
  595.       4:setlevel;
  596.       5:killdatabase;
  597.       6:reorderdata;
  598.       7:renamedata
  599.     end
  600.   until (q=1) or hungupon or (filesize(ddfile)=0)
  601. end;
  602.  
  603. var q:integer;
  604. begin
  605.   cursection:=databasesysop;
  606.   openddfile;
  607.   if filesize(ddfile)=0 then exit;
  608.   curbasenum:=1;
  609.   seek (ddfile,0);
  610.   read (ddfile,curbase);
  611.   if curbase.level>ulvl then begin
  612.     reqlevel (curbase.level);
  613.     close (ddfile);
  614.     exit
  615.   end;
  616.   openefile;
  617.   repeat
  618.     writeln (^B^M'Active: ['^S,curbase.basename,^R']');
  619.     writeln ('Entries: '^S,curbase.numents);
  620.     q:=menu('Database Command','DBASE','QA*SLVNH%@CD');
  621.     case q of
  622.       2:adddata;
  623.       3:selectdata;
  624.       4:searchdata;
  625.       5:listdata;
  626.       6:newscan;
  627.       7:newscanall;
  628.       8:help ('Database.hlp');
  629.       9:sysopcommands;
  630.       10:changedata;
  631.       11:deletedata
  632.     end
  633.   until hungupon or (q=1) or (filesize(ddfile)=0);
  634.   close (ddfile);
  635.   close (efile)
  636. end;
  637.  
  638. begin
  639. end.
  640.