{ Simple text file database

  Copyright (C) 2001-2006 Frank Heckenbach <frank@pascal.gnu.de>

  This unit is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published
  by the Free Software Foundation; either version 2, or (at your
  option) any later version.

  This unit is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this unit; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA. }

{$if __GPC_RELEASE__ < 20041017}
{$error This program requires GPC release 20041017 or newer.}
{$endif}

unit DBText;

interface

uses GPC, StringUtils;

const
  DBYes = 'y';
  DBNo = 'n';

type
  PDataEntries = ^TDataEntries;
  TDataEntries (Fields, Records: Integer) = record
    Field: array [1 .. Fields] of PString;
    Data: array [0 .. Records, 1 .. Fields] of PString
  end;

  TFieldID = Integer;

  TErrorProc = ^procedure (const Msg: String);

  PData = ^TData;
  TData = object
    constructor Init (aErrorProc: TErrorProc; const DataFileName, IDFieldName: String);
    destructor Done;
    function  GetFileName: TString;
    procedure Store;
    procedure StoreTo (const aFileName: String);
    function  GetError: TString;
    function  Fields: Integer;
    function  Records: Integer;
    function  GetFieldName (FieldID: TFieldID): PString;
    function  GetFieldNoError (const FieldName: String) = i: TFieldID;
    function  GetField   (const FieldName: String) = i: TFieldID;
    function  GetString  (RecordID: Integer; FieldID: TFieldID): PString;
    function  GetInteger (RecordID: Integer; FieldID: TFieldID): Integer;
    function  GetBoolean (RecordID: Integer; FieldID: TFieldID): Boolean;
    function  FindString (FieldID: TFieldID; const Val: String) = i: Integer;
    function  FindStringCheck (FieldID: TFieldID; const Val: String) = i: Integer;
    function  FindStringCase (FieldID: TFieldID; const Val: String) = i: Integer;
    function  FindStringCaseCheck (FieldID: TFieldID; const Val: String) = i: Integer;
    procedure SetString  (RecordID: Integer; FieldID: TFieldID; const Val: String);
    procedure SetInteger (RecordID: Integer; FieldID: TFieldID; Val: Integer);
    procedure SetBoolean (RecordID: Integer; FieldID: TFieldID; Val: Boolean);
    function  NewRecord = j: Integer;
    function  NewField (const FieldName: String; After: TFieldID) = i: TFieldID;
    procedure DeleteRecord (RecordID: Integer);
    procedure DeleteField (FieldID: TFieldID);
    IDField: TFieldID;
  private
    DataFile: Text;
    ErrorMsg: TString;
    ErrorProc: TErrorProc;
    Entries: PDataEntries;
    FileName: PString;
    procedure SetError (const Msg: String);
    procedure ResizeData (NFields, NRecords: Integer; ExactSize: Boolean);
  end;

function QuoteDataEntry (const s: String): TString;

implementation

constructor TData.Init (aErrorProc: TErrorProc; const DataFileName, IDFieldName: String);
var
  NFields, NRecords, FileModeSave, i, j: Integer;
  s, v: TString;
begin
  ErrorProc := aErrorProc;
  New (Entries, 64, 64);
  NRecords := 0;
  NFields := 0;
  FileModeSave := FileMode;
  FileMode := FileMode_Text_Reset_ReadWrite;
  Reset (DataFile, DataFileName);
  FileMode := FileModeSave;
  if Binding (DataFile).Writable and not FileLock (DataFile, True, True) then
    begin
      SetError ('cannot lock data file');
      Fail
    end;
  repeat
    ReadLn (DataFile, s);
    if s = '' then Break;
    j := Pos (':', s);
    v := TrimBothStr (Copy (s, j + 1));
    Delete (s, j);
    Inc (NFields);
    if NFields > Entries^.Fields then ResizeData (NFields, NRecords, False);
    Entries^.Field[NFields] := NewString (s);
    Entries^.Data[0, NFields] := NewString (v)
  until False;
  if NFields = 0 then
    begin
      SetError ('No fields');
      Fail
    end;
  i := 0;
  while not EOF (DataFile) do
    begin
      ReadLn (DataFile, s);
      if s = '' then
        begin
          if i < NFields then
            begin
              SetError ('Missing fields in record ' + Integer2String (NRecords));
              Fail
            end;
          i := 0
        end
      else
        begin
          if i = 0 then
            begin
              Inc (NRecords);
              if NRecords > Entries^.Records then ResizeData (NFields, NRecords, False)
            end;
          Inc (i);
          j := Pos (':', s);
          v := TrimBothStr (Copy (s, j + 1));
          Delete (s, j);
          if i > NFields then
            begin
              SetError ('Too many fields in record ' + Integer2String (NRecords));
              Fail
            end;
          if s <> Entries^.Field[i]^ then
            begin
              SetError ('Field #' + Integer2String (i) + ' `' + s + ''', `' + Entries^.Field[i]^ + '''');
              Fail
            end;
          if not UnQPString (v) then
            begin
              SetError ('invalid data `' + v + '''');
              Fail
            end;
          Entries^.Data[NRecords, i] := NewString (v)
        end
    end;
  if i <> 0 then
    begin
      SetError ('Incomplete last record');
      Fail
    end;
  if NRecords = 0 then
    begin
      SetError ('No Entries');
      Fail
    end;
  ResizeData (NFields, NRecords, True);
  FileName := NewString (DataFileName);
  IDField := GetField (IDFieldName)
end;

destructor TData.Done;
var i, j: Integer;
begin
  Close (DataFile);
  Dispose (FileName);
  for i := 1 to Entries^.Fields do
    begin
      Dispose (Entries^.Field[i]);
      for j := 0 to Entries^.Records do
        Dispose (Entries^.Data[j, i])
    end;
  Dispose (Entries)
end;

function TData.GetFileName: TString;
begin
  GetFileName := FileName^
end;

procedure TData.Store;
begin
  StoreTo (FileName^)
end;

function QuoteDataEntry (const s: String): TString;
begin
  QuoteDataEntry := QuoteStringEscape (s, #0, False)
end;

procedure TData.StoreTo (const aFileName: String);
var FileModeSave, i, j: Integer;
begin
  Rewrite (DataFile, aFileName);
  if not FileLock (DataFile, True, True) then SetError ('cannot lock data file');
  for i := 0 to Entries^.Records do
    begin
      for j := 1 to Entries^.Fields do
        if Entries^.Data[i, j]^ = '' then
          WriteLn (DataFile, Entries^.Field[j]^, ':')
        else
          WriteLn (DataFile, Entries^.Field[j]^, ': ', QuoteDataEntry (Entries^.Data[i, j]^));
      WriteLn (DataFile)
    end;
  FileModeSave := FileMode;
  FileMode := FileMode_Text_Reset_ReadWrite;
  Reset (DataFile);
  FileMode := FileModeSave;
  if not FileLock (DataFile, True, True) then SetError ('cannot lock data file')
end;

procedure TData.ResizeData (NFields, NRecords: Integer; ExactSize: Boolean);
var
  i, j: Integer;
  NewEntries: PDataEntries;
begin
  if ExactSize then
    New (NewEntries, NFields, NRecords)
  else
    begin
      i := Entries^.Fields;
      while i < NFields do i := 2 * i;
      j := Entries^.Records;
      while j < NRecords do j := 2 * j;
      New (NewEntries, i, j)
    end;
  for i := 1 to Min (Entries^.Fields, NFields) do
    begin
      NewEntries^.Field[i] := Entries^.Field[i];
      for j := 0 to Min (Entries^.Records, NRecords) do
        NewEntries^.Data[j, i] := Entries^.Data[j, i]
    end;
  Dispose (Entries);
  Entries := NewEntries
end;

procedure TData.SetError (const Msg: String);
begin
  ErrorMsg := Msg;
  if ErrorProc <> nil then ErrorProc^ (Msg)
end;

function TData.GetError: TString;
begin
  GetError := ErrorMsg
end;

function TData.Fields: Integer;
begin
  Fields := Entries^.Fields
end;

function TData.Records: Integer;
begin
  Records := Entries^.Records
end;

function TData.GetFieldName (FieldID: TFieldID): PString;
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) then
    begin
      SetError ('GetFieldName (' + Integer2String (FieldID) + ')');
      GetFieldName := nil
    end
  else
    GetFieldName := Entries^.Field[FieldID]
end;

function TData.GetFieldNoError (const FieldName: String) = i: TFieldID;
begin
  i := Entries^.Fields;
  while (i > 0) and (Entries^.Field[i]^ <> FieldName) do Dec (i)
end;

function TData.GetField (const FieldName: String) = i: TFieldID;
begin
  i := GetFieldNoError (FieldName);
  if i = 0 then SetError ('GetField `' + FieldName + '''')
end;

function TData.GetString (RecordID: Integer; FieldID: TFieldID): PString;
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) or (RecordID < 0) or (RecordID > Entries^.Records) then
    begin
      SetError ('GetString (' + Integer2String (RecordID) + ', ' + Integer2String (FieldID) + ')');
      GetString := nil
    end
  else
    GetString := Entries^.Data[RecordID, FieldID]
end;

function TData.GetInteger (RecordID: Integer; FieldID: TFieldID): Integer;
var r, e: Integer;
begin
  Val (GetString (RecordID, FieldID)^, r, e);
  if e <> 0 then
    begin
      SetError ('GetInteger (' + Integer2String (RecordID) + ', ' + Integer2String (FieldID) + ')');
      GetInteger := 0
    end
  else
    GetInteger := r
end;

function TData.GetBoolean (RecordID: Integer; FieldID: TFieldID): Boolean;
var p: PString;
begin
  p := GetString (RecordID, FieldID);
  if (p^ = '') or (p^ = DBNo) then
    GetBoolean := False
  else if p^ = DBYes then
    GetBoolean := True
  else
    begin
      SetError ('GetBoolean (' + Integer2String (RecordID) + ', ' + Integer2String (FieldID) + ')');
      GetBoolean := False
    end
end;

function TData.FindString (FieldID: TFieldID; const Val: String) = i: Integer;
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) then
    SetError ('FindString (' + Integer2String (FieldID) + ')')
  else
    for i := 0 to Entries^.Records do
      if Entries^.Data[i, FieldID]^ = Val then Exit;
  i := -1
end;

function TData.FindStringCheck (FieldID: TFieldID; const Val: String) = i: Integer;
begin
  i := FindString (FieldID, Val);
  if i < 0 then SetError ('FindStringCheck (' + Integer2String (FieldID) + ', ' + Val + ')')
end;

function TData.FindStringCase (FieldID: TFieldID; const Val: String) = i: Integer;
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) then
    SetError ('FindStringCase (' + Integer2String (FieldID) + ')')
  else
    for i := 0 to Entries^.Records do
      if StrEqualCase (Entries^.Data[i, FieldID]^, Val) then Exit;
  i := -1
end;

function TData.FindStringCaseCheck (FieldID: TFieldID; const Val: String) = i: Integer;
begin
  i := FindStringCase (FieldID, Val);
  if i < 0 then SetError ('FindStringCaseCheck (' + Integer2String (FieldID) + ', ' + Val + ')')
end;

procedure TData.SetString (RecordID: Integer; FieldID: TFieldID; const Val: String);
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) or (RecordID < 0) or (RecordID > Entries^.Records) then
    SetError ('SetString (' + Integer2String (RecordID) + ', ' + Integer2String (FieldID) + ')')
  else
    begin
      Dispose (Entries^.Data[RecordID, FieldID]);
      Entries^.Data[RecordID, FieldID] := NewString (Val)
    end
end;

procedure TData.SetInteger (RecordID: Integer; FieldID: TFieldID; Val: Integer);
var s: String (64);
begin
  WriteStr (s, Val);
  SetString (RecordID, FieldID, s)
end;

procedure TData.SetBoolean (RecordID: Integer; FieldID: TFieldID; Val: Boolean);
const NY: array [Boolean] of String (1) = ('', DBYes);
begin
  SetString (RecordID, FieldID, NY[Val])
end;

function TData.NewRecord = j: Integer;
var i, n: Integer;
begin
  j := Entries^.Records + 1;
  ResizeData (Entries^.Fields, j, True);
  for i := 1 to Entries^.Fields do
    Entries^.Data[j, i] := NewString (Entries^.Data[0, i]^);
  n := 0;
  for i := 0 to j - 1 do
    n := Max (n, GetInteger (i, IDField));
  Inc (n);
  SetInteger (j, IDField, n)
end;

function TData.NewField (const FieldName: String; After: TFieldID) = i: TFieldID;
var j, k, n: Integer;
begin
  for k := 1 to Entries^.Fields do
    if Entries^.Field[k]^ = FieldName then
      Return 0;
  if (After < 0) or (After > Entries^.Fields) then
    SetError ('NewField (' + Integer2String (After));
  n := Entries^.Fields;
  ResizeData (n + 1, Entries^.Records, True);
  i := After + 1;
  for k := n downto i do Entries^.Field[k + 1] := Entries^.Field[k];
  Entries^.Field[i] := NewString (FieldName);
  for j := 0 to Entries^.Records do
    begin
      for k := n downto i do Entries^.Data[j, k + 1] := Entries^.Data[j, k];
      Entries^.Data[j, i] := NewString ('')
    end
end;

procedure TData.DeleteRecord (RecordID: Integer);
var i, j: Integer;
begin
  if (RecordID < 0) or (RecordID > Entries^.Records) or (Entries^.Records <= 1) then
    SetError ('DeleteRecord (' + Integer2String (RecordID) + ')')
  else
    with Entries^ do
      begin
        for i := 1 to Fields do Dispose (Data[RecordID, i]);
        for j := RecordID to Records - 1 do Data[j] := Data[j + 1];
        ResizeData (Fields, Records - 1, True)
      end
end;

procedure TData.DeleteField (FieldID: TFieldID);
var i, j: Integer;
begin
  if (FieldID < 1) or (FieldID > Entries^.Fields) then
    SetError ('DeleteField (' + Integer2String (FieldID) + ')')
  else
    with Entries^ do
      begin
        Dispose (Field[FieldID]);
        for i := FieldID to Fields - 1 do Field[i] := Field[i + 1];
        for j := 0 to Records do
          begin
            Dispose (Data[j, FieldID]);
            for i := FieldID to Fields - 1 do Data[j, i] := Data[j, i + 1]
          end;
        ResizeData (Fields - 1, Records, True)
      end
end;

end.