home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDBASE.ZIP / GS_DBASE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-01-08  |  13.8 KB  |  533 lines
  1. unit GS_DBASE;
  2.  
  3. {      GS_DBASE Copyright (c)  Richard F. Griffin
  4.  
  5.        8 January 1990
  6.  
  7.        102 Molded Stone Pl
  8.        Warner Robins, GA  31088
  9.  
  10.        -------------------------------------------------------------
  11.        This unit handles the objects for all dBase III file (.DBF)
  12.        operations.
  13.  
  14.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  15. }
  16.  
  17.  
  18. interface
  19. uses dos, GS_DB_IX;
  20.  
  21. const
  22.    GS_dBase_MaxRecBytes = 4000; { dBASE III record limit }
  23.    GS_dBase_MaxRecField = 128; { dBASE III field limit  }
  24.  
  25.    Next_Record = -1;
  26.    Prev_Record = -2;
  27.    Top_Record  = -3;
  28.    Bttm_Record = -4;
  29.  
  30.    GS_dBase_UnDltChr = 32;   {Character for Undeleted Record}
  31.    GS_dBase_DltChr   = 42;   {Character for Deleted Record}
  32.  
  33. type
  34.    GS_dBase_Status = (NotOpen, NotUpdated, Updated);
  35.    GS_dBase_dRec = ^GS_dBase_DataRecord;
  36.    GS_dBase_DataRecord = ARRAY[0..GS_dBase_MaxRecBytes] OF Byte;
  37.  
  38.    GS_dBase_Head = Record
  39.                       DBType     : Byte;
  40.                       Year       : Byte;
  41.                       Month      : Byte;
  42.                       Day        : Byte;
  43.                       RecCount   : LongInt;
  44.                       Location   : Integer;
  45.                       RecordLen  : Integer;
  46.                       Reserved   : Array[1..20] of Byte;
  47.                    end;
  48.  
  49.    GS_dBase_Field = Record
  50.                        FieldName    : Array[1..11] of Char;
  51.                        FieldType    : Char;
  52.                        FieldAddress : LongInt;
  53.                        FieldLen     : Byte;
  54.                        FieldDec     : Byte;
  55.                        Reserved     : Array[1..14] of Char;
  56.                     end;
  57.  
  58.    GS_dBase_dFld = ^GS_dBase_DataField;
  59.    GS_dBase_DataField = ARRAY[1..GS_dBase_MaxRecField] OF GS_dBase_Field;
  60.  
  61.    GS_dBase_DB = object
  62.       FileName     : string[64];
  63.       dFile        : file;
  64.       mFile        : file;
  65.       HeadProlog   : GS_dBase_Head;
  66.       dStatus      : GS_dBase_Status;
  67.       WithMemo     : Boolean;
  68.       DateOfUpdate : string[8];
  69.       NumRecs      : LongInt;
  70.       HeadLen      : Integer;
  71.       RecLen       : Integer;
  72.       NumFields    : Integer;
  73.       Fields       : GS_dBase_dFld;
  74.       RecNumber    : LongInt;
  75.       CurRecord    : GS_dBase_dRec;
  76.       DelFlag      : boolean;
  77.       dbfError     : Integer;
  78.       dbfOK        : Boolean;
  79.       File_EOF     : boolean;
  80.       Found        : boolean;
  81.       dbfNdxTbl    : array [1..16] of GS_Indx_LPtr;
  82.       dbfNdxActv   : boolean;
  83.       PROCEDURE Append;
  84.       PROCEDURE Close;
  85.       PROCEDURE Create(FName : string; Flds : GS_dBase_dFld; FCnt : integer);
  86.       PROCEDURE Delete;
  87.       PROCEDURE Find(st : string);
  88.       PROCEDURE GetRec(RecNum: LongInt);
  89.       PROCEDURE Index(IName : String);
  90.       PROCEDURE Init(FName : string);
  91.       PROCEDURE Open;
  92.       PROCEDURE Pack;
  93.       PROCEDURE PutRec(RecNum : LongInt);
  94.       PROCEDURE UnDelete;
  95.    end;
  96.  
  97.  
  98.  
  99. implementation
  100.  
  101. CONST
  102.   DB3File = 3;
  103.   DB3WithMemo = $83;
  104.  
  105. PROCEDURE GS_dBase_DB.GetRec(RecNum : LongInt);
  106. VAR
  107.    Result : Integer;
  108.    RNum   : LongInt;
  109. BEGIN
  110.    RNum := RecNum;
  111.    if (dbfNdxActv) and (RecNum < 0) then
  112.       RNum := dbfNdxTbl[1]^.KeyRead(RecNum);
  113.    case RNum of
  114.       Next_Record : begin
  115.                        RNum := RecNumber + 1;
  116.                        if RNum > NumRecs then RNum := NumRecs;
  117.                     end;
  118.       Prev_Record : begin
  119.                        RNum := RecNumber - 1;
  120.                        if RNum < 1 then RNum := 1;
  121.                     end;
  122.       Top_Record  : RNum := 1;
  123.       Bttm_Record : RNum := NumRecs;
  124.    end;
  125.    if (RNum < 1) or (RNum > NumRecs) then
  126.    begin
  127.       dbfOK := false;
  128.       dbfError := 100  {Disk read beyond EOF};
  129.       exit;
  130.    end;
  131.    {$I-} Seek(dFile, HeadLen+(RNum-1) * RecLen); {$I+}
  132.    dbfError := IOResult;
  133.    IF dbfError = 0 THEN
  134.    BEGIN
  135.       {$I-} BlockRead(dFile, CurRecord^, RecLen, Result); {$I+}
  136.       dbfError := IOResult;
  137.       IF (dbfError = 0) AND (Result < RecLen) THEN
  138.          dbfError := 100;  {Partial read only}
  139.       RecNumber := RNum;
  140.       if CurRecord^[0] = GS_dBase_UnDltChr then DelFlag := false
  141.          else DelFlag := true;
  142.    END;
  143.    dbfOK := (dbfError = 0);
  144.    if (dbfNdxActv) and (RecNum < 0) then
  145.       File_EOF := dbfNdxTbl[1]^.KeyEOF
  146.    else if RecNumber = NumRecs then File_EOF := true else File_EOF := false;
  147. END;                        {GetRec}
  148.  
  149. Procedure GS_dBase_DB.Find(st : string);
  150. var
  151.    RNum   : longint;
  152. begin
  153.    if (dbfNdxActv) then
  154.       RNum := dbfNdxTbl[1]^.KeyFind(st);
  155.    if RNum > 0 then GetRec(RNum);
  156. end;
  157.  
  158.  
  159. PROCEDURE GS_dBase_DB.PutRec(RecNum : LongInt);
  160. VAR
  161.    Result : Integer;
  162.    RNum   : LongInt;
  163. BEGIN
  164.    RNum := RecNum;
  165.    IF (RNum > NumRecs) or (RNum < 1) then
  166.    begin
  167.       inc(NumRecs);
  168.       RNum := NumRecs;
  169.    end;
  170.    {$I-} Seek(dFile, HeadLen + (RNum-1) * RecLen); {$I+}
  171.    dbfError := IOResult;
  172.    IF dbfError = 0 THEN
  173.    BEGIN
  174.       {$I-} BlockWrite(dFile, CurRecord^, RecLen, Result); {$I+}
  175.       dbfError := IOResult;
  176.       RecNumber := RNum;
  177.       dStatus := Updated;
  178.    end;
  179.    dbfOK := (dbfError = 0);
  180. END;                        {PutRec}
  181.  
  182. PROCEDURE GS_dBase_DB.Append;
  183. BEGIN
  184.    PutRec(0);
  185. END;
  186.  
  187. PROCEDURE GS_dBase_DB.Delete;
  188. begin
  189.    DelFlag := true;
  190.    CurRecord^[0] := GS_dBase_DltChr;
  191.    PutRec(RecNumber);
  192. end;
  193.  
  194. PROCEDURE GS_dBase_DB.UnDelete;
  195. begin
  196.    DelFlag := false;
  197.    CurRecord^[0] := GS_dBase_UnDltChr;
  198.    PutRec(RecNumber);
  199. end;
  200.  
  201. PROCEDURE GS_dBase_DB.Close;
  202. CONST
  203.    EofMark : Byte = $1A;
  204. var
  205.    yy, mm, dd, wd : word;
  206.  
  207.    procedure UpDate_File;
  208.    BEGIN
  209.       GetDate (yy,mm,dd,wd);
  210.       HeadProlog.year := yy-1900; {Year}
  211.       HeadProlog.month := mm; {Month}
  212.       HeadProlog.day := dd; {Day}
  213.       HeadProlog.RecCount := NumRecs;
  214.       {$I-}Seek(dFile, 0);{$I+}
  215.       dbfError := IOResult;
  216.       IF dbfError = 0 THEN
  217.       BEGIN
  218.          {$I-} BlockWrite(dFile, HeadProlog, 8); {$I+}
  219.          dbfError := IOResult;
  220.       END;
  221.       dbfOK := (dbfError = 0);
  222.       IF dbfError = 0 THEN
  223.       BEGIN
  224.          {$I-} Seek(dFile, HeadLen+NumRecs*RecLen); {$I+}
  225.          dbfError := IOResult;
  226.       END;
  227.       IF dbfError = 0 THEN
  228.       BEGIN
  229.          {$I-} BlockWrite(dFile, EofMark, 1); {$I+} {Put EOF marker }
  230.          dbfError := IOResult;
  231.       END;
  232.    END;   { IF Updated }
  233.  
  234. begin
  235.    dbfError := 0;
  236.    IF dStatus = NotOpen THEN exit;
  237.    IF dStatus = Updated THEN UpDate_File;
  238.    IF dbfError = 0 THEN
  239.    BEGIN
  240.       {$I-} System.Close(dFile);     {$I+}
  241.       if WithMemo then System.Close(mFile);
  242.       dbfError := IOResult;
  243.       dStatus := NotOpen;
  244.    END;
  245.    dbfOK := (dbfError = 0);
  246. END;                        { GS_dBase_Close }
  247.  
  248. PROCEDURE GS_dBase_DB.Open;
  249. BEGIN                       { GS_dBase_Open }
  250.    if dStatus = NotOpen then
  251.    begin
  252.       Assign(dFile, FileName);
  253.       {$I-} Reset(dFile, 1); {$I+}
  254.       dbfError := IOResult;
  255.       dbfOK := (dbfError = 0);
  256.       dStatus := NotUpdated;
  257.       if WithMemo then Reset(mFile,512);
  258.       RecNumber := 0;
  259.    end;
  260. END;                        { GS_dBase_Open }
  261.  
  262. PROCEDURE GS_dBase_DB.Init(FName : string);
  263. var
  264.    i : integer;
  265.  
  266.    PROCEDURE ProcessHeader;
  267.    VAR
  268.       Result : integer;
  269.       o, i : Integer;
  270.       m,dy,y : string[2];
  271.    BEGIN                     {ProcessHeader}
  272.       CASE HeadProlog.DBType OF
  273.          DB3File : WithMemo := False;
  274.          DB3WithMemo : WithMemo := True;
  275.          ELSE
  276.          BEGIN
  277.             dbfError := 157;  {Not dBase file (Unknown Media)}
  278.             System.Close(dFile);
  279.             Exit;
  280.          END;
  281.       END;                      {CASE}
  282.       Str(HeadProlog.month,m);
  283.       if length(m) = 1 then m := '0'+m;
  284.       Str(HeadProlog.day,dy);
  285.       if length(dy) = 1 then dy := '0'+dy;
  286.       Str(HeadProlog.year,y);
  287.       if length(y) = 1 then y := '0'+y;
  288.       DateOfUpdate := m + '/' + dy + '/' + y;
  289.       NumRecs := HeadProlog.RecCount;
  290.       HeadLen := HeadProlog.Location;
  291.       RecLen := HeadProlog.RecordLen;
  292.       RecNumber := 0;
  293.       File_EOF := false;
  294.       GetMem(Fields, HeadLen-33); { Allocate memory for a buffer  }
  295.       NumFields := (HeadLen - 33) div 32;
  296.       {$I-} BlockRead(dFile, Fields^,HeadLen-33, Result); {$I+}
  297.    END;                      {ProcessHeader}
  298.  
  299.    PROCEDURE GetHeader;
  300.    VAR
  301.       Result : Integer;
  302.    BEGIN                     { GetHeader }
  303.       {$I-} BlockRead(dFile, HeadProlog, 32, Result); {$I+}
  304.       dbfError := IOResult;
  305.       IF dbfError = 0 THEN ProcessHeader;
  306.    END;                      { GetHeader }
  307.  
  308. begin
  309.    Filename := FName+'.DBF';
  310.    Assign(dFile, FileName);
  311.    {$I-} Reset(dFile, 1); {$I+}
  312.    dbfError := IOResult;
  313.    dbfOK := (dbfError = 0);
  314.    if dbfOK then
  315.    begin
  316.       GetHeader;
  317.       System.Close(dFile);
  318.       GetMem(CurRecord, RecLen); { Allocate memory for a buffer  }
  319.    end;
  320.    dStatus := NotOpen;
  321.    dbfNdxActv := false;
  322.    for i := 1 to 16 do dbfNdxTbl[i] := nil;
  323.    if WithMemo then assign(mFile, FName+'.DBT');
  324. end;
  325.  
  326. PROCEDURE GS_dBase_DB.Create(FName : string; Flds: GS_dBase_dFld;
  327.                              FCnt : integer);
  328. CONST
  329.    EofMark : Byte = $1A;
  330.    EohMark : Byte = $0D;
  331. var
  332.    yy, mm, dd, wd : word;
  333.    i, rl          : integer;
  334.  
  335.    procedure Make_GS_Head;
  336.    VAR
  337.       m,dy,y : string[2];
  338.    begin
  339.       Str(mm,m);
  340.       if length(m) = 1 then m := '0'+m;
  341.       Str(dd,dy);
  342.       if length(dy) = 1 then dy := '0'+dy;
  343.       Str(yy,y);
  344.       if length(y) = 1 then y := '0'+y;
  345.       DateOfUpdate := m + '/' + dy + '/' + y;
  346.       NumRecs := 0;
  347.       HeadLen := HeadProlog.Location;
  348.       RecLen := rl;
  349.       RecNumber := 0;
  350.       NumFields := FCnt;
  351.    end;
  352.  
  353.    procedure MakeHeader;
  354.    var
  355.       i : integer;
  356.    BEGIN
  357.       HeadProlog.DBType := DB3File;
  358.       GetDate (yy,mm,dd,wd);
  359.       HeadProlog.year := yy-1900; {Year}
  360.       HeadProlog.month := mm; {Month}
  361.       HeadProlog.day := dd; {Day}
  362.       HeadProlog.RecCount := 0;
  363.       HeadProlog.Location := (FCnt*32) + 33;
  364.       rl := 1;
  365.       for i := 1 to FCnt do rl := rl + Flds^[i].FieldLen;
  366.       HeadProlog.RecordLen := rl;
  367.       FillChar(HeadProlog.Reserved,20,#0);
  368.       {$I-}Seek(dFile, 0);{$I+}
  369.       dbfError := IOResult;
  370.       IF dbfError = 0 THEN
  371.       BEGIN
  372.          {$I-} BlockWrite(dFile, HeadProlog, 32); {$I+}
  373.          dbfError := IOResult;
  374.       END;
  375.       IF dbfError = 0 THEN
  376.       BEGIN
  377.          {$I-} BlockWrite(dFile, Flds^, FCnt*32); {$I+}
  378.          dbfError := IOResult;
  379.       END;
  380.       IF dbfError = 0 THEN
  381.       BEGIN
  382.          {$I-} BlockWrite(dFile, EohMark, 1); {$I+} {Put EOH marker }
  383.          dbfError := IOResult;
  384.       END;
  385.       IF dbfError = 0 THEN
  386.       BEGIN
  387.          {$I-} BlockWrite(dFile, EofMark, 1); {$I+} {Put EOF marker }
  388.          dbfError := IOResult;
  389.       END;
  390.       dbfOK := (dbfError = 0);
  391.    END;   { IF Updated }
  392.  
  393. begin
  394.    Filename := FName+'.DBF';
  395.    Assign(dFile, FileName);
  396.    {$I-} Rewrite(dFile, 1); {$I+}
  397.    dbfError := IOResult;
  398.    dbfOK := (dbfError = 0);
  399.    if dbfOK then
  400.    begin
  401.       MakeHeader;
  402.       Make_GS_Head;
  403.       Fields := Flds;
  404.       System.Close(dFile);
  405.       GetMem(CurRecord, RecLen); { Allocate memory for a buffer  }
  406.    end;
  407.    dStatus := NotOpen;
  408. END;                        { GS_dBase_Create }
  409.  
  410. PROCEDURE GS_dBase_DB.PACK;
  411. CONST
  412.    EofMark : Byte = $1A;
  413.    EohMark : Byte = $0D;
  414.    ZroMark : Byte = $00;
  415.  
  416. var
  417.    df : file;
  418.  
  419.    Procedure Copy_Recs;
  420.    var
  421.       i, j : longint;
  422.    begin
  423.       j := 0;
  424.       for i := 1 to NumRecs do
  425.       begin
  426.          GetRec(i);
  427.          if not DelFlag then
  428.          begin
  429.            {$I-} BlockWrite(df, CurRecord^, RecLen); {$I+}
  430.            dbfError := IOResult;
  431.            inc(j);
  432.          end;
  433.       end;
  434.       NumRecs := j;
  435.       {$I-} BlockWrite(df, EofMark, 1); {$I+} {Put EOF marker }
  436.       dbfError := IOResult;
  437.    end;
  438.  
  439.    Procedure Copy_Head;
  440.    var
  441.       delta : integer;
  442.    begin
  443.       {$I-}Seek(df, 0);{$I+}
  444.       dbfError := IOResult;
  445.       IF dbfError = 0 THEN
  446.       BEGIN
  447.          {$I-} BlockWrite(df, HeadProlog, 32); {$I+}
  448.          dbfError := IOResult;
  449.       END;
  450.       IF dbfError = 0 THEN
  451.       BEGIN
  452.          {$I-} BlockWrite(df, Fields^, NumFields*32); {$I+}
  453.          dbfError := IOResult;
  454.       END;
  455.       IF dbfError = 0 THEN
  456.       BEGIN
  457.          {$I-} BlockWrite(df, EohMark, 1); {$I+} {Put EOH marker }
  458.          dbfError := IOResult;
  459.       END;
  460.       delta := (NumFields*32) + 33;
  461.       while delta <> HeadProlog.Location do
  462.       begin
  463.          {$I-} BlockWrite(df, ZroMark, 1); {$I+} {Put Zero }
  464.          inc(delta);
  465.       end;
  466.       dbfOK := (dbfError = 0);
  467.    end;
  468.  
  469. begin
  470.    Assign(df, 'DB$$$.DB$');
  471.    {$I-} Rewrite(df, 1); {$I+}
  472.    dbfError := IOResult;
  473.    dbfOK := (dbfError = 0);
  474.    if dbfOK then
  475.    begin
  476.       Copy_Head;
  477.       Copy_Recs;
  478.    end;
  479.    dStatus := UpDated;
  480.    System.Close(dFile);
  481.    System.Close(df);
  482.    Erase(dFile);
  483.    Rename(df, Filename);
  484.    Assign(dFile, FileName);
  485.    {$I-} Reset(dFile, 1); {$I+}
  486.    Close;
  487.    Open;
  488. END;                        { GS_dBase_Pack }
  489.  
  490. Procedure GS_dBase_DB.Index (IName : String);
  491. var
  492.    i,j : integer;
  493.    st  : String[64];
  494. begin
  495.    i := 1;
  496.    while dbfNdxTbl[i] <> nil do
  497.    begin
  498.       System.Close(dbfNdxTbl[i]^.Ndx_File);
  499.       Dispose(dbfNdxTbl[i]);
  500.       dbfNdxTbl[i] := nil;
  501.       inc(i);
  502.    end;
  503.    i := 0;
  504.    j := 1;
  505.    st := '';
  506.    while j <= length(IName) do
  507.    begin
  508.       if (IName[j] <> ' ') and (IName[j] <> ',') then
  509.          st := st + IName[j]
  510.       else
  511.       begin
  512.          inc(i);
  513.          if st <> '' then
  514.          begin
  515.             New(dbfNdxTbl[i]);
  516.             dbfNdxTbl[i]^.Init(st);
  517.          end;
  518.          st := '';
  519.       end;
  520.       inc(j);
  521.    end;
  522.    inc(i);
  523.    if st <> '' then
  524.    begin
  525.       New(dbfNdxTbl[i]);
  526.       dbfNdxTbl[i]^.Init(st);
  527.    end;
  528.    if i > 0 then dbfNdxActv := true;
  529. end;
  530.  
  531.  
  532. end.
  533.