home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / Samples / TBASE551.ARJ / TBDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-12-19  |  8.2 KB  |  277 lines
  1. Program TbDemo;
  2. (*=============================================================================
  3. +  This Demo demonstrates the features of Tbase3 along with DbDate and DbStr +
  4. *  
  5. +============================================================================*)
  6. Uses Crt, Tbase, DbDate, DbStr;
  7.  
  8. Var     Ch : Char ; { A Spare one to read any key }
  9.     Opt : INTEGER ;
  10.  
  11. Procedure MemCheck;
  12.                 (*======================================*
  13.         *  Checks the proper memory allocation  *
  14.         *  and deallocation.                    *
  15.         *=======================================*)
  16. Var MyDb : DataObject;
  17.      Mv  : LongInt ;
  18. Begin
  19.     ClrScr ;
  20.     Mv := MemAvail ;
  21.     Writeln('Memory available Before Opening Dbase file :' , MemAvail);
  22. New( MyDb , Init('DbStr.Dbf') );
  23.     Writeln('Memory available After  Opening Dbase File :' , MemAvail);
  24.     Writeln('Memory used for opening ''DbStr.Dbf'' file :' , Mv-Memavail);
  25. Dispose( MyDb , done ) ;
  26.     Writeln('Memory After closing Dbase File with Done  :' , MemAvail );
  27.     Writeln; Writeln(' Any key now...');
  28.     ch := Readkey ;
  29. End;
  30.  
  31. Procedure CreateAndAdd ;
  32.         (*=======================================================
  33.          *  Create a Dbase file and add some fields.        *
  34.          *  No need to go to Dbase III or FoxPro for this    *
  35.          *======================================================*)
  36. Var MyDb : DataObject ;
  37. Begin
  38. Clrscr;
  39. Writeln( ' Creating a Dbase File Demo.Dbf now...', #10#10);
  40. CreateDbFile('Demo.Dbf');  { This is NOT part of Object. }
  41.                    { Does not check for existing file. }
  42.                    { Be careful.. Next version will check }
  43. Writeln(' Now you should open the file to manipulate..');
  44. New( MyDb , Init('Demo.Dbf') );  { Open the file now.. One field is there }
  45.                      { With the name 'NEWFIELD','C' , 10 ,0 }
  46. With MyDb^ do
  47. Begin
  48.  
  49. Writeln(' Displayig the field in the fresh Dbase file..', #10#10);
  50. DisplayFields;             { Just see the fields }
  51. Writeln(' Changing and Adding field now.. and listing again..',#10);
  52.  
  53. ChangeField('NewField','Cust_no', 'N',6,0 ) ; { Change the first Field}
  54. AddField('Cust_Name','C',20,0);               { One more field }
  55. AddField('Cust_Addr','C',20,0);               { Ok.. One more }
  56. AddField('Date' , 'D', 100 , 0 ); { A date field.. Note that Field length    }
  57.                       { and decimals are ignored and put its own.}
  58.                       { But you give it for the sake of argumant }
  59. Addfield('BlaBla', 'K' , 10,0 ) ; { A wrong info.. This will be ignored }
  60.                       { With the Bleep and Dberror = 15 set }
  61.                       { Dberror = 15 - Invalid Field }
  62. Writeln;
  63. Write( '*Error* -', LastDbError ); { Just calling to clear the error. Otherwise,
  64.                   All the rest calls are ignored }
  65.  
  66. Writeln( '- Invalid Field Type ****  Due to the deliberate mistake ' );writeln;
  67.  
  68. DisplayFields;        { Now we will see what happened }
  69. End;
  70. Dispose(MyDb, Done );   { Happy!!  Close it then ! }
  71.     
  72.     Writeln;
  73.     Writeln( ' Any key now..');
  74.     ch := Readkey;
  75. End;
  76.  
  77. Procedure AddData;
  78.         (*=====================================================
  79.          *  Adding some data to field.. Deleting.. packing    *
  80.          *  Recalling.. Note that Any Screen Comfort is NOT   *
  81.          *  Provided by Tbase3 yet. Next versions may have    *
  82.          *  some if Users want in Text Mode.              *
  83.          *  But a Graphical Input Object is underway          *
  84.          *====================================================*)
  85. Var MyDb : DataObject ;
  86.       Sysday : Date ;     {  Dbdate features also included }
  87.     i : longint;
  88.     DateField : String ;     { Str8 is enough }
  89.     hh , mm , ss, s100 : Word ;
  90.     h1,m1,s1,s101 : Word ;
  91. Begin
  92.     If not FileExists('Demo.Dbf') then 
  93.     Begin
  94.         Warnerror(1) ;
  95.         Writeln(#10#10,  ' Demo.Dbf is not yet created to Open.. ');
  96.         Writeln(' Try Option 2 first to create Demo.Dbf..');
  97.         Writeln(' Any key now..');
  98.         Ch := Readkey ;
  99.         Exit;
  100.     End;
  101.     
  102.     Clrscr;
  103.     Today( Sysday ) ;  { Get the System Date- DBdate.TPU } 
  104.     Writeln(' Opening a Demo.Dbf again ');
  105.     New( MyDb , Init('Demo.Dbf') ); 
  106.     Writeln('Adding 1000 records With Random Data....');
  107.     For i := 1 to 1000 do With MyDb^ do
  108.     Begin
  109.         ClearMemRec;    { Clear the memory rec to avoid Garbage data}
  110.         Replace('Cust_Name' , 'Nasir' + Cstr( i, 4, 0) );
  111.  
  112.                 { Data is Nasir0001 to Nasir1000 }
  113.                 { Notice the field name is used to replace }
  114.         Replace('Cust_Addr', 'Sri Lanka Only' );
  115.         Replace('Cust_no', Cstr(i,6,0) ); { Replace Only Accept String}
  116.                           { Even if it is Numeric }
  117.                           { Use ReplNum for numeric }
  118.         DateAfter( SysDay , 1 ) ;         { Add one by one to sysday }
  119.         DateField := DateToFormat( SysDay ); { Prepare for Replace }
  120.                     { Wrong date are ignored by check }
  121.         Replace('Date' , dateField );      (* Replace now accepts Format *)
  122.         AddDbRec;      { Finally Add it to file }
  123.     End;    
  124.     Dispose( myDb, Done );
  125.     Writeln;
  126.     Writeln( ' Any key now..');
  127.     Ch := Readkey;
  128.  
  129. End;
  130.  
  131. Procedure DeleteTest;
  132. Var MyDb: DataObject;
  133.     i : longInt;
  134. Begin
  135.     If not FileExists('Demo.Dbf') then 
  136.     Begin
  137.         Warnerror(1) ;
  138.         Writeln(#10#10,  ' Demo.Dbf is not yet created to Open.. ');
  139.         Writeln(' Try Option 2 first to create Demo.Dbf..');
  140.         Writeln(' Any key now..');
  141.         Ch := Readkey ;
  142.         Exit;
  143.     End;
  144.  
  145.     New( MyDb , Init('Demo.Dbf') );
  146.     Writeln('Deleting Even numbered records...');
  147.     For i := 1 to 500 do with MyDb^ do
  148.     Begin
  149.         GetDbRec( i*2 );
  150.         DbDelete;      { No need to rewrite as Autosave is ON- Default}
  151.     End; 
  152. Dispose( MyDb , Done );
  153.     Writeln;
  154.     Writeln( ' Any key now..');
  155.     Ch := Readkey;
  156. End;
  157.  
  158. Procedure PackTest;
  159. Var MyDb : DataObject;
  160. Begin
  161.     If not FileExists('Demo.Dbf') then 
  162.     Begin
  163.         Warnerror(1) ;
  164.         Writeln(#10#10,  ' Demo.Dbf is not yet created to Open.. ');
  165.         Writeln(' Try Option 2 first to create Demo.Dbf..');
  166.         Writeln(' Any key now..');
  167.         Ch := Readkey ;
  168.         Exit;
  169.     End;
  170.  
  171.     New( MyDb , Init('Demo.Dbf') );
  172.     Writeln( ' Packing Demo.Dbf..... ' );
  173.     MyDb^.Pack ;                 { Pack them }
  174.  
  175. Dispose( MyDb , Done );
  176.     Writeln;
  177.     Writeln( ' Any key now..');
  178.     Ch := Readkey;
  179. End;
  180.  
  181. Procedure  ZapTest;
  182.         (*==================================================*
  183.          *  Zaps the Demo.Dbf                     *
  184.          *==================================================*)
  185. Var MyDb : DataObject ;
  186. Begin
  187.     If not FileExists('Demo.Dbf') then 
  188.     Begin
  189.         Warnerror(1) ;
  190.         Writeln(#10#10,  ' Demo.Dbf is not yet created to Open.. ');
  191.         Writeln(' Try Option 2 first to create Demo.Dbf..');
  192.         Writeln(' Any key now..');
  193.         Ch := Readkey ;
  194.         Exit;
  195.     End;
  196.  
  197.     New( MyDb , Init('Demo.Dbf') );
  198.     Clrscr;
  199.     Writeln( ' Zapping the Demo.Dbf... ');
  200. With MyDb^ do
  201. Begin
  202.     Zap;     { That's it!!! }
  203.     Writeln('Number of Records now is :' , RecCount :10 );
  204. End;
  205.     Dispose( MyDb , done );
  206.  
  207.     Writeln;
  208.     Writeln(' Any Key Now..');
  209.     ch := Readkey
  210. End;
  211.  
  212. Procedure  RecoverTest;
  213.         (*==================================================*
  214.          *  TRIES to Recover as much                  *
  215.          *  as Possible. No Guarantee Whatsoever is given   *
  216.          *  But, I have a Feeling that the First cluster    *
  217.          *  of the file will be protected forever..        *
  218.          *==================================================*)
  219. Var MyDb : DataObject ;
  220. Begin
  221.  
  222.     If not FileExists('Demo.Dbf') then 
  223.     Begin
  224.         Warnerror(1) ;
  225.         Writeln(#10#10,  ' Demo.Dbf is not yet created to Open.. ');
  226.         Writeln(' Try Option 2 first to create Demo.Dbf..');
  227.         Writeln(' Any key now..');
  228.         Ch := Readkey ;
  229.         Exit;
  230.     End;
  231.  
  232.     Clrscr;
  233.     New(myDb , Init('Demo.Dbf') );
  234.     Writeln( ' Recovering the Demo.Dbf... ');
  235. With MyDb^ do
  236. Begin
  237.     Recover(500) ;     { 500 records are targetted }
  238.     Writeln('  73 records will be guaranteed to be recovered on Hard Disk');
  239.     Writeln(' 146 record will be recovered on Hard disk with Stacker' );
  240.     Writeln(' Formula for calculation : TRUNC( Clusterbytes/Recsize ) ' );
  241.     Dispose( MyDb , done );
  242. End;
  243.     Writeln;
  244.     Writeln(' Any Key Now..');
  245.     ch := Readkey
  246. End;
  247.  
  248.  
  249. Begin
  250.  
  251.       Repeat
  252.     Clrscr ;
  253.     Writeln(' 1. Memory Allocation Test ' );
  254.     Writeln(' 2. Create Dbase Test');
  255.     Writeln(' 3. Data Append Test ' );
  256.     Writeln(' 4. Data Delete Test' );
  257.     Writeln(' 5. Pack Test ' );
  258.     Writeln(' 6. Zap  Test ');
  259.     Writeln(' 7. Recover Test ');
  260.     Writeln(' 0. Exit the Tests ');
  261.     Writeln;
  262.     Write(' Select your Option ' );
  263.     Readln(Opt);
  264.     Case Opt of 
  265.         1 : MemCheck;
  266.         2 : CreateAndAdd;
  267.         3 : AddData ;
  268.         4 : DeleteTest;
  269.         5 : PackTest;
  270.         6 : ZapTest;
  271.         7 : RecoverTest;
  272.     End;
  273.       until Opt = 0 ;
  274.  
  275.     Writeln( ' Thats all for now.. Happy?');
  276. End.
  277.