home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDBASE.ZIP / DB_MAKE.PAS next >
Encoding:
Pascal/Delphi Source File  |  1990-01-08  |  6.1 KB  |  198 lines
  1. program DB_Make;
  2.  
  3. {      DB_Make Copyright (c)  Richard F. Griffin
  4.  
  5.        8 January 1990
  6.  
  7.        102 Molded Stone Pl
  8.        Warner Robins, GA  31088
  9.  
  10.        -------------------------------------------------------------
  11.  
  12.        This program creates the .PAS unit for a dBase III file.
  13.        The resulting unit creates objects for each data field and
  14.        the entire database.  The units HLTH_UNT.PAS and HLTHDATA.PAS
  15.        demonstrate the resulting units.
  16.  
  17.        The program expects two parameters:  The dBase file, without
  18.        the .DBF extension, and the name you want the resulting unit
  19.        to have.
  20.  
  21.        For example, the HLTH_UNT.PAS unit was created by executing:
  22.  
  23.        DM_MAKE HEALTH Hlth_Unt
  24.  
  25.        If the second parameter is left out, the unit will take the
  26.        the first parameter.
  27.  
  28. }
  29.  
  30. uses
  31.    Crt, dos, GS_Dbase;
  32.  
  33. var
  34.    FileN        :  GS_dBase_DB;
  35.    display_Name :  string[12];
  36.    In_Name      :  string[12];
  37.    Outfile      :  text;
  38.    i, k, os, fs :  integer;
  39.  
  40. function Fld_Num(inum, slen : integer) : string;
  41. var
  42.    data : string[10];
  43.    k : integer;
  44. begin
  45.    str(inum:slen, data);
  46.    for k := 1 to slen do if data[k] = ' ' then data[k] := '0';
  47.    Fld_Num := data;
  48. end;
  49.  
  50.  
  51.   PROCEDURE DisplayStructure;
  52.  
  53.   VAR
  54.     i, k, v : Integer;
  55.  
  56.   BEGIN
  57.     ClrScr;
  58.  
  59.     writeln(outfile,'type');
  60.     FOR i := 1 TO FileN.NumFields DO
  61.     BEGIN
  62.       WITH FileN.Fields^[i] DO
  63.       BEGIN
  64.          write(outfile,'   ',display_Name,'_FL',Fld_Num(i,3));
  65.          write(outfile,'':10-length(display_Name),'=  Object(GS_dBase_FL');
  66.          case FieldType of
  67.             'C' : write(outfile,'_C)');
  68.             'D' : write(outfile,'_D)');
  69.             'N' : begin
  70.                      if FieldDec = 0 then write(outfile,'_I)')
  71.                         else write(outfile,'_R)');
  72.                   end;
  73.             'M' : write(outfile,'_M)');
  74.             'L' : write(outfile,'_L)');
  75.          end;
  76.          write(outfile,'      {');
  77.          for k := 1 to 11 do
  78.             if FieldName[k] = #0 then write(outfile,' ')
  79.                else write(outfile,FieldName[k]);
  80.          writeln(outfile,'}');
  81.          writeln(outfile,'':25,'constructor   Init(LF, LR : pointer);');
  82.          writeln(outfile,'':22,'end;');
  83.          writeln(outfile);
  84.       end;
  85.     end;
  86.     write(outfile,'   ',display_Name,'_Objct');
  87.     writeln(outfile,'':10-length(display_Name),'=  Object(GS_dBase_DB)');
  88.     FOR i := 1 TO FileN.NumFields DO
  89.     BEGIN
  90.       WITH FileN.Fields^[i] DO
  91.       BEGIN
  92.          write(outfile,'':25);
  93.          for k := 1 to 11 do
  94.             if FieldName[k] = #0 then write(outfile,' ')
  95.                else write(outfile,FieldName[k]);
  96.          write(outfile,' : ');
  97.          writeln(outfile,display_Name,'_FL',Fld_Num(i,3),';');
  98.       end;
  99.     END;                    {FOR}
  100.     writeln(outfile,'':22,'end;');
  101.   END;                        { DisplayStructure }
  102.  
  103. begin
  104.    clrscr;
  105.    if paramcount < 1 then exit;
  106.    In_Name := ParamStr(1);
  107.    if paramcount = 2 then Display_Name := ParamStr(2)
  108.       else Display_Name := In_Name;
  109.    FileN.Init(In_Name);
  110.    FileN.Open;
  111.    IF NOT FileN.dbfOK THEN exit;
  112.    assign(Outfile,display_Name+'.PAS');
  113.    rewrite(Outfile);
  114.    writeln(outfile,'unit ',display_Name,';');
  115.    writeln(outfile);
  116.    writeln(outfile,'interface');
  117.    writeln(outfile,'uses');
  118.    writeln(outfile,'   GS_dBase, GS_DB_FL;');
  119.    writeln(outfile);
  120.    DisplayStructure;
  121.    writeln(outfile);
  122.    writeln(outfile,'var');
  123.    writeln(outfile,'   ',display_Name,'_R    : ',Display_Name,'_Objct;');
  124.    writeln(outfile,'   ',display_Name,'_Exit : pointer;');
  125.    writeln(outfile);
  126.    writeln(outfile,'implementation');
  127.    writeln(outfile);
  128.    writeln(outfile,'type');
  129.    writeln(outfile,'   PtrRec  =  record');
  130.    writeln(outfile,'                 ofs, seg : word;');
  131.    writeln(outfile,'              end;');
  132.    writeln(outfile);
  133.    os := 1;
  134.    fs := 1;
  135.     FOR i := 1 TO FileN.NumFields DO
  136.     BEGIN
  137.       WITH FileN.Fields^[i] DO
  138.       BEGIN
  139.          writeln(outfile,'constructor ',display_Name,'_FL',Fld_Num(i,3),
  140.                          '.Init(LF, LR : pointer);');
  141.          writeln(outfile,'begin');
  142.          writeln(outfile,'   OffSet := ',os,';');
  143.          writeln(outfile,'   Inc(PtrRec(LF).ofs,',(fs-1)*32,');');
  144.          writeln(outfile,'   Inc(PtrRec(LR).ofs,',os,');');
  145.          write(outfile,'   GS_dBase_FL');
  146.          case FieldType of
  147.             'C' : write(outfile,'_C');
  148.             'D' : write(outfile,'_D');
  149.             'N' : begin
  150.                      if FieldDec = 0 then write(outfile,'_I')
  151.                         else write(outfile,'_R');
  152.                   end;
  153.             'M' : write(outfile,'_M');
  154.             'L' : write(outfile,'_L');
  155.          end;
  156.          writeln(outfile,'.Init(LF, LR);');
  157.          if FieldType = 'M' then
  158.             writeln(outfile,'   File_ptr := @',display_Name,'_R.mFile;');
  159.          writeln(outfile,'end;');
  160.          writeln(outfile);
  161.          inc(fs);
  162.          os := os + FieldLen;
  163.       end;
  164.     end;
  165.  
  166.  
  167.  
  168.  
  169.    writeln(outfile,'{$F+}');
  170.    writeln(outfile,'procedure Exit_Proc;');
  171.    writeln(outfile,'begin');
  172.    writeln(outfile,'   ',display_Name,'_R.Close;');
  173.    writeln(outfile,'   exitProc := ',display_Name,'_Exit;');
  174.    writeln(outfile,'end;');
  175.    writeln(outfile);
  176.    writeln(outfile,'begin');
  177.    writeln(outfile,'   ',display_Name,'_Exit := exitProc;');
  178.    writeln(outfile,'   exitProc := @Exit_Proc;');
  179.    writeln(outfile,'   ',display_Name,'_R.Init(',#39,In_Name,#39,');');
  180.    writeln(outfile,'   with ',display_Name,'_R do');
  181.    writeln(outfile,'   begin');
  182.  
  183.    FOR i := 1 TO FileN.NumFields DO
  184.    BEGIN
  185.       WITH FileN.Fields^[i] DO
  186.       BEGIN
  187.          write(outfile,'':6);
  188.          for k := 1 to 11 do
  189.             if FieldName[k] <> #0 then write(outfile,FieldName[k]);
  190.          writeln(outfile,'.Init(Fields, CurRecord);');
  191.       end;
  192.     END;                    {FOR}
  193.    writeln(outfile,'   end;');
  194.    writeln(outfile,'   ',display_Name,'_R.Close;');
  195.    writeln(outfile,'end.');
  196.    FileN.Close;
  197.    close(outfile);
  198. end.