home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / commercial-software / programming / TURBODBT.ZIP / BTREE.INC < prev    next >
Text File  |  1996-07-15  |  13KB  |  485 lines
  1. (*******************************************************)
  2. (*                                                     *)
  3. (*         TURBO-ACCESS Version 1.2 (CP/M-80)          *)
  4. (*                                                     *)
  5. (*              Database Example Program               *)
  6. (*                 - Include Module -                  *)
  7. (*                                                     *)
  8. (*         Use with TURBO PASCAL 2.0 or later          *)
  9. (*                                                     *)
  10. (*              Copyright (C) 1984,85 by               *)
  11. (*               Borland International                 *)
  12. (*                                                     *)
  13. (*******************************************************)
  14.  
  15.  
  16. (*  UpcaseStr converts a string to upper case *)
  17.  
  18. function UpcaseStr(S : Str80) : Str80;
  19. var
  20.   P : Integer;
  21. begin
  22.   for P := 1 to Length(S) do 
  23.     S[P] := Upcase(S[P]);
  24.   UpcaseStr := S;
  25. end;
  26.  
  27. (*  ConstStr returns a string with N characters of value C *)
  28.  
  29. function ConstStr(C : Char; N : Integer) : Str80;
  30. var
  31.   S : string[80];
  32. begin
  33.   if N < 0 then 
  34.     N := 0; 
  35.   S[0] := Chr(N); 
  36.   FillChar(S[1],N,C);
  37.   ConstStr := S;
  38. end;
  39.  
  40. (*  Beep sounds the terminal bell or beeper *)
  41.  
  42. procedure Beep;
  43. begin
  44.   Write(^G);
  45. end;
  46.  
  47.  
  48. procedure InputStr(var S     : AnyStr;
  49.                        L,X,Y : Integer;
  50.                        Term  : CharSet;
  51.                    var TC    : Char    );
  52. const
  53.   UnderScore  =  '_';
  54. var
  55.   P : Integer;
  56.   Ch : Char;
  57. begin
  58.   GotoXY(X + 1,Y + 1); Write(S,ConstStr(UnderScore,L - Length(S)));
  59.   P := 0;
  60.   repeat
  61.     GotoXY(X + P + 1,Y + 1); Read(Kbd,Ch);
  62.     case Ch of
  63.       #32..#126 : if P < L then
  64.                   begin
  65.                     if Length(S) = L then
  66.                       Delete(S,L,1);
  67.                     P := P + 1;
  68.                     Insert(Ch,S,P);
  69.                     Write(Copy(S,P,L));
  70.                   end
  71.                   else Beep;
  72.       ^S        : if P > 0 then
  73.                     P := P - 1
  74.                   else Beep;
  75.       ^D        : if P < Length(S) then
  76.                     P := P + 1
  77.                   else Beep;
  78.       ^A        : P := 0;
  79.       ^F        : P := Length(S);
  80.       ^G        : if P < Length(S) then
  81.                   begin
  82.                     Delete(S,P + 1,1);
  83.                     Write(Copy(S,P + 1,L),UnderScore);
  84.                   end;
  85.       ^H,#127   : if P > 0 then
  86.                   begin
  87.                     Delete(S,P,1);
  88.                     Write(^H,Copy(S,P,L),UnderScore);
  89.                     P := P - 1;
  90.                   end
  91.                   else Beep;
  92.       ^Y        : begin
  93.                     Write(ConstStr(UnderScore,Length(S) - P));
  94.                     Delete(S,P + 1,L);
  95.                   end;
  96.     else
  97.       if not (Ch in Term) then Beep;
  98.     end;  {of case}
  99.   until Ch in Term;
  100.   P := Length(S);
  101.   GotoXY(X + P + 1,Y + 1);
  102.   Write('' :L - P);
  103.   TC := Ch;
  104. end;
  105.  
  106.  
  107. procedure Select(    Prompt : Str80;
  108.                      Term   : CharSet;
  109.                  var TC     : Char    );
  110. var
  111.   Ch : Char;
  112. begin
  113.   GotoXY(1,23); Write(Prompt,'? ' ); ClrEol;
  114.   repeat
  115.     Read(Kbd,Ch);
  116.     TC := Upcase(Ch);
  117.     if not (TC in Term) then
  118.       Beep;
  119.   until TC in Term;
  120.   Write(Ch);
  121. end;
  122.  
  123. (*  ClearFrame clears the display frame, I.E. Lines 3 to 20 *)
  124.  
  125. procedure ClearFrame;
  126. var
  127.   I : Integer;
  128. begin
  129.   for I := 3 to 20 do
  130.   begin
  131.     GotoXY(1,I + 1); ClrEol ;
  132.   end;
  133. end;
  134.  
  135. (*  OutForm displays the entry form on the screen *)
  136.  
  137. procedure OutForm;
  138. begin
  139.   GotoXY(7,5); Write('Code :');
  140.   GotoXY(29,5); Write('Date :');
  141.   GotoXY(1,7); Write('First name :');
  142.   GotoXY(29,7); Write('Last name :');
  143.   GotoXY(4,9); Write('Company :');
  144.   GotoXY(2,10); Write('Address 1 :');
  145.   GotoXY(2,11); Write('Address 2 :');
  146.   GotoXY(6,13); Write('Phone :');
  147.   GotoXY(29,13); Write('Extension :');
  148.   GotoXY(2,15); Write('Remarks 1 :');
  149.   GotoXY(2,16); Write('Remarks 2 :');
  150.   GotoXY(2,17); Write('Remarks 3 :');
  151. end;
  152.  
  153. (*  ClearForm clears all fields in the entry form *)
  154.  
  155. procedure ClearForm;
  156. begin
  157.   GotoXY(13,5); Write('' :15);
  158.   GotoXY(35,5); ClrEol;
  159.   GotoXY(13,7); Write('' :15);
  160.   GotoXY(40,7); ClrEol;
  161.   GotoXY(13,9); ClrEol;
  162.   GotoXY(13,10); ClrEol;
  163.   GotoXY(13,11); ClrEol;
  164.   GotoXY(13,13); Write('' :15);
  165.   GotoXY(40,13); ClrEol;
  166.   GotoXY(13,15); ClrEol;
  167.   GotoXY(13,16); ClrEol;
  168.   GotoXY(13,17); ClrEol;
  169. end;
  170.  
  171.  
  172. procedure InputCust(var Cust : CustRec);
  173. const
  174.   Term : CharSet  =  [^E,^I,^M,^X,^Z];
  175. var
  176.   L : Integer;
  177.   TC : Char;
  178. begin
  179.   L := 1;
  180.   with Cust do
  181.   repeat
  182.     case L of
  183.       1 : InputStr(CustCode,15,12,4,Term,TC);
  184.       2 : InputStr(EntryDate,8,34,4,Term,TC);
  185.       3 : InputStr(FirstName,15,12,6,Term,TC);
  186.       4 : InputStr(LastName,30,39,6,Term,TC);
  187.       5 : InputStr(Company,40,12,8,Term,TC);
  188.       6 : InputStr(Addr1,30,12,9,Term,TC);
  189.       7 : InputStr(Addr2,30,12,10,Term,TC);
  190.       8 : InputStr(Phone,15,12,12,Term,TC);
  191.       9 : InputStr(PhoneExt,5,39,12,Term,TC);
  192.       10 : InputStr(Remarks1,40,12,14,Term,TC);
  193.       11 : InputStr(Remarks2,40,12,15,Term,TC);
  194.       12 : InputStr(Remarks3,40,12,16,Term,TC);
  195.     end;
  196.     if (TC = ^I) or (TC = ^M) or (TC = ^X) then
  197.       if L = 12 then
  198.         L := 1
  199.       else L := L + 1
  200.     else
  201.       if TC = ^E then
  202.         if L = 1 then
  203.           L := 12
  204.         else L := L - 1;
  205.   until (TC = ^M) and (L = 1) or (TC = ^Z);
  206. end;
  207.  
  208. (*  OutCust displays the customer data contained in Cust *)
  209.  
  210. procedure OutCust(var Cust : CustRec);
  211. begin
  212.   with Cust do
  213.   begin
  214.     GotoXY(13,5); Write(CustCode,'' :15 - Length(CustCode));
  215.     GotoXY(35,5); Write(EntryDate); ClrEol ;
  216.     GotoXY(13,7); Write(FirstName,'' :15 - Length(FirstName));
  217.     GotoXY(40,7); Write(LastName); ClrEol;
  218.     GotoXY(13,9); Write(Company); ClrEol;
  219.     GotoXY(13,10); Write(Addr1); ClrEol;
  220.     GotoXY(13,11); Write(Addr2); ClrEol;
  221.     GotoXY(13,13); Write(Phone,'' :15 - Length(Phone));
  222.     GotoXY(40,13); Write(PhoneExt); ClrEol;
  223.     GotoXY(13,15); Write(Remarks1); ClrEol;
  224.     GotoXY(13,16); Write(Remarks2); ClrEol;
  225.     GotoXY(13,17); Write(Remarks3); ClrEol;
  226.   end;
  227. end;
  228.  
  229.  
  230. function KeyFromName(LastNm : Str15; FirstNm : Str10) : Str25;
  231. const
  232.   Blanks  =  '               ';
  233. begin
  234.   KeyFromName := UpcaseStr(LastNm) + 
  235.                  Copy(Blanks,1,15 - Length(LastNm)) +
  236.                  UpcaseStr(FirstNm);
  237. end;
  238.  
  239. (*  Update is used to update the data base *)
  240.  
  241. procedure Update;
  242. var
  243.   Ch : Char;
  244.  
  245. (*  Add is used to add customers *)
  246.  
  247. procedure Add;
  248. var
  249.   DataF : Integer;
  250.   Ccode : string[15];
  251.   KeyN  : string[25];
  252.   Cust  : CustRec;
  253. begin
  254.   with Cust do
  255.   begin
  256.     FillChar(Cust,SizeOf(Cust),0);
  257.     repeat
  258.       InputCust(Cust);
  259.       Ccode := CustCode;
  260.       FindKey(CodeIndexFile, DataF,Ccode);
  261.       if OK then
  262.       begin
  263.         GotoXY(6,19);
  264.         Write('ERROR : Duplicate customer code');
  265.         Beep;
  266.       end;
  267.     until not OK;
  268.     AddRec(DatF,DataF,Cust);
  269.     AddKey(CodeIndexFile, DataF,CustCode);
  270.     KeyN := KeyFromName(LastName,FirstName);
  271.     AddKey(NameIndexFile, DataF,KeyN);
  272.     GotoXY(6,19); ClrEol;
  273.   end;
  274. end;
  275.  
  276. (*  Find is used to find, edit and delete customers *)
  277.  
  278. procedure Find;
  279. var
  280.   D,L,I   : Integer;
  281.   Ch,
  282.   TC      : Char;
  283.   Ccode,
  284.   PCode,
  285.   FirstNm : string[15];
  286.   KeyN,
  287.   PNm     : string[25];
  288.   LastNm  : string[30];
  289.   Cust    : CustRec;
  290. begin
  291.   if UsedRecs(DatF) > 0 then
  292.   begin
  293.     Ccode := '';
  294.     repeat
  295.       InputStr(Ccode,15,12,4,[^M,^Z],TC);
  296.       if Ccode <> '' then
  297.       begin
  298.         FindKey(CodeIndexFile,D,Ccode);
  299.         if OK then
  300.         begin
  301.           GetRec(DatF,D,Cust); 
  302.           OutCust(Cust);
  303.         end
  304.         else
  305.         begin
  306.           GotoXY(6,19);
  307.           Write('ERROR : Customer code not found'); Beep;
  308.         end;
  309.       end;
  310.     until OK or (Ccode = '');
  311.     GotoXY(6,19); ClrEol;
  312.     if Ccode = '' then
  313.     begin
  314.       L := 1; 
  315.       FirstNm := ''; 
  316.       LastNm := '';
  317.       repeat
  318.         case L of
  319.           1 : InputStr(FirstNm,15,12,6,[^I,^M,^Z],TC);
  320.           2 : InputStr(LastNm,30,39,6,[^I,^M,^Z],TC);
  321.         end;
  322.         if (TC = ^I) or (TC = ^M) then 
  323.           L := 3 - L;
  324.       until (TC = ^M) and (L = 1) or (TC = ^Z);
  325.       KeyN := KeyFromName(LastNm,FirstNm); 
  326.       SearchKey(NameIndexFile, D,KeyN);
  327.       if not OK then 
  328.         PrevKey(NameIndexFile,D,KeyN);
  329.       repeat
  330.         GetRec(DatF,D,Cust); 
  331.         OutCust(Cust);
  332.         Select('Find : N)ext, P)revious, Q)uit',['N','P','Q'],Ch);
  333.         case Ch of
  334.           'N' : repeat NextKey(NameIndexFile, D,KeyN) until OK;
  335.           'P' : repeat PrevKey(NameIndexFile, D,KeyN) until OK;
  336.         end;
  337.       until Ch = 'Q';
  338.     end;
  339.     Select('Find : E)dit, D)elete, Q)uit',['E','D','Q'],Ch);
  340.     with Cust do
  341.     case Ch of
  342.       'E' : begin
  343.               PCode := CustCode; 
  344.               PNm := KeyFromName(LastName,FirstName);
  345.               repeat
  346.                 InputCust(Cust);
  347.                 if CustCode = PCode then 
  348.                   OK := false
  349.                 else
  350.                 begin
  351.                   Ccode := CustCode; 
  352.                   FindKey(CodeIndexFile, I,Ccode); 
  353.                   if OK then Beep;
  354.                 end;
  355.               until not OK;
  356.               PutRec(DatF,D,Cust);
  357.               if CustCode <> PCode then
  358.               begin
  359.                 DeleteKey(CodeIndexFile, D,PCode);
  360.                 AddKey(CodeIndexFile, D,CustCode);
  361.               end;
  362.               KeyN := KeyFromName(LastName,FirstName);
  363.               if KeyN <> PNm then
  364.               begin
  365.                 DeleteKey(NameIndexFile, D,PNm);
  366.                 AddKey(NameIndexFile, D,KeyN);
  367.               end;
  368.             end;
  369.       'D' : begin
  370.               DeleteKey(CodeIndexFile,D,CustCode);
  371.               KeyN := KeyFromName(LastName,FirstName); 
  372.               DeleteKey(NameIndexFile,D,KeyN);
  373.               DeleteRec(DatF,D);
  374.       end;
  375.     end;
  376.   end { of UsedRecs(DatF) > 0 .. }
  377.   else Beep;
  378. end;
  379.  
  380. begin(* Update*)
  381.   OutForm;
  382.   repeat
  383.     Select('Update : A)dd, F)ind, Q)uit',['A','F','Q'],Ch);
  384.     case Ch of
  385.       'A' : Add;
  386.       'F' : Find;
  387.     end;
  388.     if Ch <> 'Q' then
  389.     begin
  390.       GotoXY(60,2); Write(UsedRecs(DatF) :5);
  391.       ClearForm;
  392.     end;
  393.   until Ch = 'Q';
  394. end;
  395.  
  396. (*  List is used to list customers *)
  397.  
  398. procedure List;
  399. label Escape;
  400. var
  401.   D,L,LD   : Integer;
  402.   Ch,CO,CS : Char;
  403.   Ccode    : string[15];
  404.   KeyN     : string[25];
  405.   Name     : string[35];
  406.   Cust     : CustRec;
  407. begin
  408.   Select('Output device : P)rinter, S)creen',['P','S'],CO);
  409.   Select('Sort by : C)ode, N)ame, U)nsorted',['C','N','U'],CS);
  410.   GotoXY(1,23); Write('Press <Esc> to abort'); ClrEol;
  411.   ClearKey(CodeIndexFile);
  412.   ClearKey(NameIndexFile);
  413.   D := 0;
  414.   LD := FileLen(DatF) - 1;
  415.   L := 3;
  416.   repeat
  417.     if KeyPressed then
  418.     begin
  419.       Read(Kbd,Ch); 
  420.       if Ch = #27 then
  421.         goto Escape;
  422.     end;
  423.     case CS of
  424.       'C' : NextKey(CodeIndexFile,D,Ccode);
  425.       'N' : NextKey(NameIndexFile,D,KeyN);
  426.       'U' : begin
  427.               OK := false;
  428.               while (D < LD) and not OK do
  429.               begin
  430.                 D := D + 1; 
  431.                 GetRec(DatF,D,Cust);
  432.                 OK := Cust.CustStatus = 0;
  433.               end;
  434.             end;
  435.     end;
  436.     if OK then
  437.       with Cust do
  438.       begin
  439.         if CS <> 'U' then 
  440.           GetRec(DatF,D,Cust);
  441.         Name := LastName;
  442.         if FirstName <> '' then 
  443.           Name := Name + ', ' + FirstName;
  444.         if CO = 'P' then
  445.         begin
  446.           Write(Lst,CustCode,'' :16 - Length(CustCode));
  447.           Write(Lst,Name,'' :36 - Length(Name));
  448.           Writeln(Lst,Copy(Company,1,25));
  449.         end
  450.         else
  451.         begin
  452.           if L = 21 then
  453.           begin
  454.             GotoXY(1,23);
  455.             Write('Press <RETURN> to continue');
  456.             Write(' or <Esc> to abort'); 
  457.             ClrEol;
  458.             repeat 
  459.               Read(Kbd,Ch)
  460.             until (Ch = ^M) or (Ch = #27);
  461.             if Ch = #27 then
  462.               goto Escape;
  463.             GotoXY(1,23);
  464.             Write('Press <Esc> to abort'); ClrEol;
  465.             ClearFrame; 
  466.             L := 3;
  467.           end;
  468.           GotoXY(1,L + 1); Write(CustCode);
  469.           GotoXY(17,L + 1); Write(Name);
  470.           GotoXY(53,L + 1); Write(Copy(Company,1,25));
  471.           L := L + 1;
  472.         end; { of with Cust do .. }
  473.     end; { of if OK .. }
  474.   until not OK;
  475.   if CO = 'S' then
  476.   begin
  477.     GotoXY(1,23); Write('Press <RETURN>'); ClrEol;
  478.     repeat 
  479.       Read(Kbd,Ch)
  480.     until Ch = ^M;
  481.   end;
  482.   Escape :
  483. end;
  484.  
  485.