Chip 1999 March/Chip_1999-03_cd.bin/zkuste/delphi/D/KBMMEMTA.ZIP/Dev/tmemtable/MemTable.pas

Pascal/Delphi Source File | 1999-01-26 | 23.9 KB | 857 lines

unit MemTable;

// TMEMTABLE v. 1.02
// =========================================================================
// An inmemory temporary table.
// Can be used as a demonstration of how to create descendents of TDataSet,
// or as in my case, to allow a program to generate temporary data that can
// be used directly by all data aware controls.
//
// Copyright 1999 Kim Bo Madsen/Optical Services - Scandinavia
// All rights reserved.
//
// You are allowed to used this component in any project for free.
// You are NOT allowed to claim that you have created this component or to
// copy its code into your own component and claim that is was your idea.
// Im offering this for free for your convinience, and the ONLY thing I request
// is to get an e-mail about what project this component (or dirived versions)
// is used for. That will be my reward of offering this component for free to you!
//
// You dont need to state my name in your software, although it would be
// appreciated if you do.
//
// If you find bugs or alter the component (f.ex. see suggested enhancements
// further down), please DONT just send the corrected/new code out on the internet,
// but instead send it to me, so I can put it into the official version. You will
// be acredited if you do so.
//
//
// DISCLAIMER
// By using this component or parts theiroff you are accepting the full
// responsibility of the use. You are understanding that the author cant be
// made responsible in any way for any problems occuring using this component.
// You also recognize the author as the creator of this component and agrees
// not to claim otherwize!
//
// Please forward corrected versions (source code ONLY!), comments,
// and emails saying you are using it for this or that project to:
//            [e-mail]
//
//=============================================================================

{$ifndef VER100} // CBuilder only
{$ObjExportAll On}
{$ASSERTIONS ON}
{$endif}

interface

uses SysUtils,Classes,Db;

type
    EMemTableError = class(Exception);

    TRecInfo=record
        Bookmark: longint;
        RecordNo: integer;
        BookmarkFlag: TBookmarkFlag;
    end;
    PRecInfo=^TRecInfo;

{
Internal buffer layout:
+------------------------+------------------------+---------------------------+
|     RECORD DATA        |    Rec.Information     |     Calculated Fields     |
| Record length bytes    |  SizeOf(TRecInfo) bytes|    CalcFieldSize bytes    |
+------------------------+------------------------+---------------------------+
                         ^                        ^
                    StartRecInfo              StartCalculated
}

  TMemTableSaveFlag = (mtfSaveData, mtfSaveCalculated, mtfSaveLookup,mtfSaveNonVisible);
  TMemTableSaveFlags = set of TMemTableSaveFlag;

  TMemTable = class(TDataSet)
  private
        FIsOpen:                                Boolean;
        FRecNo:                                 integer;
        FFilterBuffer:                          PChar;
        FRecords:                               TList;
        FBufferSize,
        FStartRecInfo,
        FStartCalculated:integer;
        FRecordSize:                            integer;
        FFieldOfs:                              array [0..255] of integer;
        FReadOnly:                              boolean;
        function GetActiveRecordBuffer:         PChar;
        function FilterRecord(Buffer: PChar):   Boolean;
        procedure _InternalAdd(Buffer:Pointer);
        procedure _InternalDelete(Pos:integer);
        procedure _InternalInsert(Pos:integer; Buffer:Pointer);
        procedure _InternalEmpty;
  protected
        procedure InternalOpen; override;
        procedure InternalClose; override;
        procedure InternalFirst;override;
        procedure InternalLast;override;

        procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
        procedure InternalDelete; override;
        procedure InternalInitRecord(Buffer: PChar); override;
        procedure InternalPost; override;

        procedure InternalInitFieldDefs; override;
        procedure InternalSetToRecord(Buffer: PChar); override;

        function IsCursorOpen: Boolean; override;
        function GetCanModify: Boolean; override;
        function GetRecordSize: Word;override;
        function GetRecordCount: integer;override;

        function AllocRecordBuffer: PChar; override;
        procedure FreeRecordBuffer(var Buffer: PChar); override;

        function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
        procedure SetFieldData(Field: TField; Buffer: Pointer);override;

        function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;

        function GetRecNo: integer;override;
        procedure SetRecNo(Value: integer);override;

        function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
        procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
        procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
        procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
        procedure InternalGotoBookmark(Bookmark: Pointer); override;

        procedure InternalHandleException; override;
  public
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        procedure LoadFromFile(const FileName: string);
        procedure LoadFromStream(Stream: TStream);
        procedure SaveToFile(const FileName: string; flags:TMemTableSaveFlags);
        procedure SaveToStream(Stream: TStream; flags:TMemTableSaveFlags);
        procedure EmptyTable;
  published
        property Active;
        property Filtered;
        property ReadOnly:boolean read FReadOnly write FReadOnly default false;
        property BeforeOpen;
        property AfterOpen;
        property BeforeClose;
        property AfterClose;
        property BeforeInsert;
        property AfterInsert;
        property BeforeEdit;
        property AfterEdit;
        property BeforePost;
        property AfterPost;
        property BeforeCancel;
        property AfterCancel;
        property BeforeDelete;
        property AfterDelete;
        property BeforeScroll;
        property AfterScroll;
        property OnCalcFields;
        property OnDeleteError;
        property OnEditError;
        property OnFilterRecord;
        property OnNewRecord;
        property OnPostError;
  end;

procedure Register;

implementation

uses
  TypInfo, Dialogs, Windows, Forms, Controls, IniFiles;

constructor TMemTable.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);
     FRecords:=TList.Create;
end;

destructor TMemTable.Destroy;
begin
     // Delete allocated records.
     _InternalEmpty;
     FRecords.free;
     FRecords:=nil;

     inherited Destroy;
end;

procedure TMemTable._InternalAdd(Buffer:Pointer);
begin
     FRecords.Add(Buffer);
end;

procedure TMemTable._InternalInsert(Pos:integer; Buffer:Pointer);
var
   i:integer;
   b:PChar;
begin
     FRecords.Insert(Pos,Buffer);

     for i:=Pos+1 to FRecords.Count-1 do
     begin
          b:=FRecords.Items[i];
          inc(PRecInfo(b+FStartRecInfo).RecordNo);
     end;
end;

procedure TMemTable._InternalDelete(Pos:integer);
var
   i:integer;
   b:PChar;
begin
     FreeMem(FRecords.Items[Pos]);
     FRecords.Delete(Pos);

     for i:=Pos to FRecords.Count-1 do
     begin
          b:=FRecords.Items[i];
          dec(PRecInfo(b+FStartRecInfo)^.RecordNo);
     end;
end;

// Purge all records.
procedure TMemTable._InternalEmpty;
var
   i:integer;
begin
     for i:=0 to FRecords.Count-1 do FreeMem(FRecords[i]);
     FRecords.Clear;
end;

procedure TMemTable.InternalOpen;
var
   i: integer;
begin
     // Calculate recordsize and field offsets.
     FRecordSize:=0;
     for i:=0 to FieldCount - 1 do
         with TField(Fields[i]) do
              if FieldKind = fkData then
              begin
                   FFieldOfs[i]:=FRecordSize;
                   inc(FRecordSize,DataSize+1); // 1.st byte is boolean flag for Null or not.
              end;

     InternalInitFieldDefs;
     BindFields(True);
     FRecNo:=-1;
     BookmarkSize:=sizeof(longint);
     FStartRecInfo:=FRecordSize;
     FStartCalculated:=FStartRecInfo+SizeOf(TRecInfo);
     FBufferSize:=FRecordSize+Sizeof(TRecInfo)+CalcFieldsSize;
     FIsOpen:=True;
end;

procedure TMemTable.InternalClose;
begin
     _InternalEmpty;
     FIsOpen:=False;
     BindFields(False);
end;

procedure TMemTable.InternalInitFieldDefs;
var
   i:integer;
begin
     FieldDefs.clear;
     for i:=0 to Fieldcount-1 do
     begin
          FieldDefs.Add(Fields[i].FieldName,Fields[i].DataType,Fields[i].Size,Fields[i].Required);
     end;
end;

function TMemTable.GetActiveRecordBuffer:  PChar;
begin
     case State of
          dsBrowse:        if IsEmpty then
                              Result := nil
                           else
                              Result := ActiveBuffer;
          dsCalcFields:    Result := CalcBuffer;
          dsFilter:        Result:=FFilterBuffer;
          dsEdit,dsInsert: Result:=ActiveBuffer;
     else
          Result:=nil;
     end;
end;

// Result is data in the buffer and a boolean return (true=not null, false=is null).
function TMemTable.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
   SourceBuffer: PChar;
begin
     Result:=False;
     SourceBuffer:=GetActiveRecordBuffer;
     if not FIsOpen or (SourceBuffer=nil) then Exit;
     if (Field.FieldKind=fkCalculated) or (Field.FieldKind=fkLookup) then
        Inc(SourceBuffer,FStartCalculated+Field.Offset)
     else
        Inc(SourceBuffer,FFieldOfs[Field.FieldNo-1]);

     if Assigned(Buffer) then Move(SourceBuffer[1], Buffer^, Field.DataSize);
     Result:=boolean(SourceBuffer[0]);
end;

procedure TMemTable.SetFieldData(Field: TField; Buffer: Pointer);
var
   DestinationBuffer: PChar;
begin
     DestinationBuffer:=GetActiveRecordBuffer;

     // Is it a calculated/lookup field or a real datafield?
     if (Field.FieldKind=fkCalculated) or (Field.FieldKind=fkLookup) then
          Inc(DestinationBuffer,FStartCalculated+Field.Offset)
     else
          Inc(DestinationBuffer,FFieldOfs[Field.FieldNo-1]);

    Boolean(DestinationBuffer[0]):=(Buffer<>nil);

    if Assigned(Buffer) then
       Move(Buffer^,DestinationBuffer[1],Field.DataSize);

    DataEvent (deFieldChange, Longint(Field));
end;

function TMemTable.IsCursorOpen: Boolean;
begin
     Result:=FIsOpen;
end;

function TMemTable.GetCanModify: Boolean;
begin
     Result:=not FReadOnly;
end;

function TMemTable.GetRecordSize: Word;
begin
     Result:=FRecordSize;
end;

function TMemTable.AllocRecordBuffer: PChar;
begin
     GetMem(Result,FBufferSize);
     FillChar(Result^,FBufferSize,0);
end;

procedure TMemTable.FreeRecordBuffer(var Buffer: PChar);
begin
     FreeMem(Buffer);
end;

procedure TMemTable.InternalFirst;
begin
     FRecNo:=-1;
end;

procedure TMemTable.InternalLast;
begin
     FRecNo:=FRecords.Count;
end;

function TMemTable.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
var
   Acceptable: Boolean;
begin
     Result:=grOK;
     Acceptable:=False;
     repeat
         begin
              case GetMode of
                   gmCurrent: begin
                                   if FRecNo>=FRecords.Count then Result:=grEOF
                                   else if FRecNo<0 then Result:=grBOF
                                   else Result:=grOk;
                              end;
                   gmNext:    begin
                                   if FrecNo<FRecords.Count-1 then
                                   begin
                                        Inc(FRecNo);
                                        Result:=grOK;
                                   end
                                   else Result:=grEOF;
                              end;
                   gmPrior:   begin
                                   if FrecNo>0 then
                                   begin
                                        Dec(FRecNo);
                                        Result:=grOK;
                                   end
                                   else Result:=grBOF;
                              end;
              end;
              if Result=grOk then
              begin
                      //fill TARrecord part of buffer
                      Move(FRecords.Items[FRecNo]^,Buffer^,FBufferSize);

                      //fill information part of buffer
                      with PRecInfo(Buffer+FStartRecInfo)^ do
                      begin
                           RecordNo:=FRecNo;
                           BookmarkFlag:=bfCurrent;
                      end;

                      //fill calc fields part of buffer
                      ClearCalcFields(Buffer);
                      GetCalcFields(Buffer);
                      Acceptable:=FilterRecord(Buffer);
                      if (GetMode=gmCurrent) and not Acceptable then Result:=grError;
              end
         end;
     until (Result<>grOk) or Acceptable;
end;

function TMemTable.FilterRecord(Buffer: PChar): Boolean;
var
   SaveState: TDatasetState;
begin
     Result:=True;
     if not Filtered or not Assigned(OnFilterRecord) then Exit;
     SaveState:=SetTempState(dsFilter);
     FFilterBuffer:=Buffer;
     OnFilterRecord(self,Result);
     RestoreState(SaveState);
end;

procedure TMemTable.InternalSetToRecord(Buffer: PChar);
begin
     FRecNo:=PRecInfo(Buffer+FStartRecInfo).RecordNo;
end;

function TMemTable.GetRecordCount: integer;
var
   SaveState: TDataSetState;
   SavePosition: integer;
   TempBuffer: PChar;
begin
     if not Filtered then Result:=FRecords.Count
     else
     begin
          Result:=0;
          SaveState:=SetTempState(dsBrowse);
          SavePosition:=FRecNo;
          try
             TempBuffer:=AllocRecordBuffer;
             InternalFirst;
             while GetRecord(TempBuffer,gmNext,True)=grOk do Inc(Result);
          finally
             RestoreState(SaveState);
             FRecNo:=SavePosition;
             FreeRecordBuffer(TempBuffer);
          end;
     end;
end;

function TMemTable.GetRecNo: integer;
var
   SaveState: TDataSetState;
   SavePosition: integer;
   TempBuffer: PChar;
begin
     if not Filtered then Result:=FRecNo
     else
     begin
          Result:=0;
          SaveState:=SetTempState(dsBrowse);
          SavePosition:=FRecNo;
          try
             TempBuffer:=AllocRecordBuffer;
             InternalFirst;
             repeat
                   if GetRecord(TempBuffer,gmNext,True)=grOk then Inc(Result);
             until PRecInfo(TempBuffer+FStartRecInfo).RecordNo=SavePosition
          finally
             RestoreState(SaveState);
             FRecNo:=SavePosition;
             FreeRecordBuffer(TempBuffer);
          end;
     end;
end;

procedure TMemTable.SetRecNo(Value: Integer);
var
   SaveState: TDataSetState;
   SavePosition: integer;
   TempBuffer: PChar;
begin
     if not Filtered then FRecNo:=Value
     else
     begin
          SaveState:=SetTempState(dsBrowse);
          SavePosition:=FRecNo;
          try
             TempBuffer:=AllocRecordBuffer;
             InternalFirst;
             repeat
                   begin
                        if GetRecord(TempBuffer,gmNext,True)=grOk then Dec(Value)
                        else
                        begin
                             FRecNo:=SavePosition;
                             break;
                        end;
                   end;
             until Value=0;
          finally
             RestoreState(SaveState);
             FreeRecordBuffer(TempBuffer);
          end;
     end;
end;

procedure TMemTable.InternalAddRecord(Buffer: Pointer; Append: Boolean);
var
   b:Pointer;
begin
     // Allocate room for buffer in list.
     GetMem(b,FBufferSize);
     Move(Buffer^, b^, FBufferSize);
     if Append then
        _InternalAdd(b)
     else
         _InternalInsert(FRecNo,b);
end;

procedure TMemTable.InternalDelete;
begin
     _InternalDelete(FRecNo);
end;

procedure TMemTable.InternalInitRecord(Buffer: PChar);
begin
     FillChar(Buffer^,FBufferSize,0);
     PRecInfo(Buffer+FStartRecInfo)^.RecordNo:=FRecNo;
end;

procedure TMemTable.InternalPost;
var
   b:pointer;
   n:integer;
begin
     n:=PRecInfo(ActiveBuffer+FStartRecInfo)^.RecordNo;
     if State = dsEdit then
        Move(ActiveBuffer^, FRecords.Items[n]^, FBufferSize)
     else
     begin
          GetMem(b,FBufferSize);
          Move(ActiveBuffer^, b^, FBufferSize);
          if GetBookmarkFlag(b) = bfEOF then
             _InternalAdd(b)
          else
             _InternalInsert(n,b);
     end;
end;

procedure TMemTable.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
     PRecInfo(Buffer + FStartRecInfo).BookmarkFlag := Value;
end;

function TMemTable.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
     Result:=PRecInfo(Buffer+FStartRecInfo).BookmarkFlag;
end;

procedure TMemTable.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
     PInteger(Data)^ := PRecInfo(Buffer + FStartRecInfo).Bookmark;
end;

procedure TMemTable.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
     PRecInfo(Buffer + FStartRecInfo).Bookmark := PInteger(Data)^;
end;

procedure TMemTable.InternalGotoBookmark (Bookmark: Pointer);
var
  ReqBookmark: Integer;
begin
     ReqBookmark := PInteger (Bookmark)^;
     if (ReqBookmark >= 0) and (ReqBookmark < RecordCount) then
        FRecNo := ReqBookmark
     else
        raise eMemTableError.Create('Bookmark ' + IntToStr(ReqBookmark) + ' not found');
end;

procedure TMemTable.InternalHandleException;
begin
     Application.HandleException(Self);
end;

procedure TMemTable.SaveToFile(const FileName: string; flags:TMemTableSaveFlags);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream,flags);
  finally
    Stream.Free;
  end;
end;

procedure TMemTable.SaveToStream(Stream: TStream; flags:TMemTableSaveFlags);
var
  i:integer;
  bm:TBookmark;
  nf:integer;
  s,a:string;
  l:integer;
  fset,f:^Boolean;
begin
  bm:=GetBookmark;

  try
     DisableControls;

     // Setup flags for fields to save.
     nf:=Fieldcount;
     GetMem(fset,nf * sizeof(boolean));
     f:=fset;
     for i:=0 to nf-1 do
     begin
          f^:=false;
          case Fields[i].FieldKind of
               fkData: if mtfSaveData in flags then f^:=true;
               fkCalculated: if mtfSaveCalculated in flags then f^:=true;
               fkLookup: if mtfSaveLookup in flags then f^:=true;
               else f^:=true;
          end;
          if not (Fields[i].Visible or (mtfSaveNonVisible in flags)) then f^:=false;
          inc(f);
     end;

     // Write all fieldnames in CSV format.
     s:='';
     a:='';
     f:=fset;
     for i:=0 to nf-1 do
     begin
          if f^ then
          begin
               s:=s+a+AnsiQuotedStr(PChar(Fields[i].Name),'"');
               a:=',';
          end;
          inc(f);
     end;
     s:=s+#13+#10;
     l:=length(s);
     Stream.Write(Pointer(s)^, l);

     // Write all records in CSV format.
     first;
     while not EOF do
     begin
          // Write current record.
          s:='';
          a:='';
          f:=fset;
          for i:=0 to nf-1 do
          begin
               if f^ then
               begin
                    if (Fields[i].IsNull) then s:=s+a
                    else s:=s+a+AnsiQuotedStr(PChar(Fields[i].AsString),'"');
                    a:=',';
               end;
               inc(f);
          end;
          s:=s+#13+#10;
          l:=length(s);
          Stream.WriteBuffer(Pointer(s)^, l);

          // Next record.
          next;
     end;
  finally
     GotoBookmark(bm);
     EnableControls;
     FreeBookmark(bm);
     FreeMem(fset);
  end;
end;

procedure TMemTable.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TMemTable.LoadFromStream(Stream: TStream);
const
   BUFSIZE=8192;
var
   i:integer;
   bm:TBookmark;
   nf:integer;
   s:string;
   size:integer;
   buf,ptr:PChar;
   buflen:integer;
   Line:string;
   lptr,elptr:PChar;
   null:boolean;

   function GetLine:boolean;
   var
     Start: PChar;
     sz:integer;
   begin
        // If less than 512 bytes left in buffer, fill up the buffer.
        // Notice: This means that if a line is longer than 1024 bytes it could fail.
        sz:=BUFSIZE-(ptr-buf);
        if (sz<512) then
        begin
             // Move the rest of data to the start of the buffer.
             if (sz>0) then Move(ptr,buf,sz);
             ptr:=buf+sz;

             // Fill up the buffer.
             buflen:=BUFSIZE;
             if Stream.Size<buflen then buflen:=Stream.Size;
             buflen:=Stream.Read(Pointer(buf)^,buflen-sz)+sz;
             ptr:=buf;
        end;

        // Check if finished.
        if ((ptr-buf) = buflen) then
        begin
             Result:=false;
             exit;
        end;

        // Cut out a line.
        Start := ptr;
        while not (ptr^ in [#0, #10, #13]) do Inc(ptr);
        SetString(Line, Start, ptr - Start);
        lptr:=PChar(Line);
        elptr:=PChar(Line)+Length(Line)-1;
        if ptr^ = #13 then Inc(ptr);
        if ptr^ = #10 then Inc(ptr);
        Result:=true;
   end;

   function GetWord(var null:boolean):string;
   var
     P, Start: PChar;
     s: string;
     sz:integer;
     l:integer;
   label
     L_exit;
   begin

     // Cut out next word.
     Start := lptr;

     Result:='';

     // Look for starting " or ,.
     while (lptr^ <> '"') and (lptr^ <> ',') and (lptr<elptr) do inc(lptr);
     if (lptr>=elptr) then exit;
     if (lptr^ = ',') then
     begin
          null:=true;
          inc(lptr);
          exit;
     end
     else null:=false;
     inc(lptr);
     Start:=lptr;

     while true do
     begin
          // Look for ending ".
          while not (lptr^ = '"') do
          begin
               if (lptr>=elptr) then goto L_exit;
               Result:=Result+lptr^;
               inc(lptr);
          end;
          inc(lptr);

          // Is it a double "" or end of word ?.
          if (lptr^ = '"') then
          begin
               Result:=Result+'"';
               inc(lptr);
               continue;
          end;

L_exit:
          // Found end, remove comma's if any.
          while (lptr<elptr) and (lptr^ = ',') do inc(lptr);
          break;
     end;
   end;

begin
  bm:=GetBookmark;

  try
     // Allocate space for a buffer.
     GetMem(buf,BUFSIZE);

     // Place pointer at end of buffer to notify getword to read a chunk of streamdata.
     ptr:=buf+BUFSIZE;

     // Read data from stream.
     nf:=Fieldcount;

     // Read headerline and skip it.
     GetLine;

     DisableControls;

     // Read all lines in CSV format.
     while GetLine do
     begin
          append;

          i:=0;
          while (lptr<elptr) and (i<nf) do
          begin
               s:=GetWord(null);
               if null then Fields[i].Clear
               else Fields[i].AsString:=s;
               inc(i);
          end;

          post;
     end;
  finally
     FreeMem(buf);
     GotoBookmark(bm);
     EnableControls;
     FreeBookmark(bm);
  end;
end;

procedure TMemTable.EmptyTable;
begin
     _InternalEmpty;
end;

procedure Register;
begin
     RegisterComponents('Data Access', [TMemTable]);
end;

end.