home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / Memtable.pas < prev    next >
Pascal/Delphi Source File  |  1999-10-12  |  15KB  |  561 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1996 AO ROSNO                   }
  6. {         Copyright (c) 1997 Master-Bank                }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit MemTable;
  11.  
  12. {$I RX.INC}
  13. {$N+,P+,S-}
  14.  
  15. interface
  16.  
  17. uses SysUtils, Classes, Controls, {$IFDEF WIN32} Bde, {$ELSE} DbiTypes,
  18.   DbiProcs, DbiErrs, {$ENDIF} DB, DBTables;
  19.  
  20. type
  21.  
  22. { TMemoryTable }
  23.  
  24.   TMemoryTable = class(TDBDataSet)
  25.   private
  26.     FTableName: TFileName;
  27.     FMoveHandle: HDBICur;
  28.     FEnableDelete: Boolean;
  29.     FDisableEvents: Boolean;
  30.     procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
  31.       const Name: string; DataType: TFieldType; Size
  32.       {$IFDEF RX_D4}, Precision {$ENDIF}: Word);
  33.     procedure SetTableName(const Value: TFileName);
  34.     function SupportedFieldType(AType: TFieldType): Boolean;
  35.     procedure DeleteCurrentRecord;
  36.   protected
  37.     function CreateHandle: HDBICur; override;
  38.     procedure DoBeforeClose; override;
  39.     procedure DoAfterClose; override;
  40.     procedure DoBeforeOpen; override;
  41.     procedure DoAfterOpen; override;
  42. {$IFDEF RX_D3}
  43.     procedure DoBeforeScroll; override;
  44.     procedure DoAfterScroll; override;
  45. {$ENDIF}
  46. {$IFDEF WIN32}
  47.     function GetRecordCount: {$IFNDEF RX_D3} Longint {$ELSE}
  48.       Integer; override {$ENDIF};
  49. {$ENDIF}
  50. {$IFDEF RX_D3}
  51.     function GetRecNo: Integer; override;
  52.     procedure SetRecNo(Value: Integer); override;
  53.     procedure InternalDelete; override;
  54. {$ELSE}
  55.     procedure DoBeforeDelete; override;
  56.     function GetRecordNumber: Longint; {$IFNDEF VER80} override; {$ENDIF}
  57.     procedure SetRecNo(Value: Longint);
  58. {$ENDIF}
  59.   public
  60.     constructor Create(AOwner: TComponent); override;
  61.     function BatchMove(ASource: TDataSet; AMode: TBatchMode;
  62.       ARecordCount: Longint): Longint;
  63.     procedure CopyStructure(ASource: TDataSet);
  64.     procedure CreateTable;
  65.     procedure DeleteTable;
  66.     procedure EmptyTable;
  67.     procedure GotoRecord(RecordNo: Longint);
  68. {$IFDEF RX_D3}
  69.     function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  70.     function IsSequenced: Boolean; override;
  71.     function Locate(const KeyFields: string; const KeyValues: Variant;
  72.       Options: TLocateOptions): Boolean; override;
  73.     function Lookup(const KeyFields: string; const KeyValues: Variant;
  74.       const ResultFields: string): Variant; override;
  75. {$ENDIF}
  76.     procedure SetFieldValues(const FieldNames: array of string;
  77.       const Values: array of const);
  78. {$IFNDEF RX_D3}
  79. {$IFNDEF VER80}
  80.     property RecordCount: Longint read GetRecordCount;
  81. {$ENDIF}
  82. {$ENDIF}
  83. {$IFNDEF RX_D3}
  84.     property RecNo: Longint read GetRecordNumber write SetRecNo;
  85. {$ENDIF}
  86.   published
  87.     property EnableDelete: Boolean read FEnableDelete write FEnableDelete
  88.       default True;
  89.     property TableName: TFileName read FTableName write SetTableName;
  90.   end;
  91.  
  92. implementation
  93.  
  94. uses DBConsts, DBUtils, BdeUtils, {$IFDEF RX_D3} BDEConst, {$ENDIF} 
  95.   Forms, MaxMin;
  96.  
  97. { Memory tables are created in RAM and deleted when you close them. They
  98.   are much faster and are very useful when you need fast operations on
  99.   small tables. Memory tables do not support certain features (like
  100.   deleting records, referntial integrity, indexes, autoincrement fields
  101.   and BLOBs) }
  102.  
  103. { TMemoryTable }
  104.  
  105. constructor TMemoryTable.Create(AOwner: TComponent);
  106. begin
  107.   inherited Create(AOwner);
  108.   FEnableDelete := True;
  109. end;
  110.  
  111. function TMemoryTable.BatchMove(ASource: TDataSet; AMode: TBatchMode;
  112.   ARecordCount: Longint): Longint;
  113. var
  114.   SourceActive: Boolean;
  115.   MovedCount: Longint;
  116. begin
  117.   if (ASource = nil) or (Self = ASource) or
  118.     not (AMode in [batCopy, batAppend]) then _DBError(SInvalidBatchMove);
  119.   SourceActive := ASource.Active;
  120.   try
  121.     ASource.DisableControls;
  122.     DisableControls;
  123.     ASource.Open;
  124.     ASource.CheckBrowseMode;
  125.     ASource.UpdateCursorPos;
  126.     if AMode = batCopy then begin
  127.       Close;
  128.       CopyStructure(ASource);
  129.     end;
  130.     if not Active then Open;
  131.     CheckBrowseMode;
  132.     if ARecordCount > 0 then begin
  133.       ASource.UpdateCursorPos;
  134.       MovedCount := ARecordCount;
  135.     end
  136.     else begin
  137.       ASource.First;
  138.       MovedCount := MaxLongint;
  139.     end;
  140.     try
  141.       Result := 0;
  142.       while not ASource.EOF do begin
  143.         Append;
  144.         AssignRecord(ASource, Self, True);
  145.         Post;
  146.         Inc(Result);
  147.         if Result >= MovedCount then Break;
  148.         ASource.Next;
  149.       end;
  150.     finally
  151.       Self.First;
  152.     end;
  153.   finally
  154.     if not SourceActive then ASource.Close;
  155.     Self.EnableControls;
  156.     ASource.EnableControls;
  157.   end;
  158. end;
  159.  
  160. procedure TMemoryTable.CopyStructure(ASource: TDataSet);
  161.  
  162.   procedure CreateField(FieldDef: TFieldDef; AOwner: TComponent);
  163.   begin
  164. {$IFDEF RX_D4}
  165.     FieldDef.CreateField(AOwner, nil, FieldDef.Name, True);
  166. {$ELSE}
  167.     FieldDef.CreateField(AOwner);
  168. {$ENDIF}
  169.   end;
  170.  
  171. var
  172.   I: Integer;
  173. begin
  174.   CheckInactive;
  175.   for I := FieldCount - 1 downto 0 do Fields[I].Free;
  176.   if (ASource = nil) then Exit;
  177.   ASource.FieldDefs.Update;
  178.   FieldDefs := ASource.FieldDefs;
  179.   for I := 0 to FieldDefs.Count - 1 do begin
  180.     if SupportedFieldType(FieldDefs.Items[I].DataType) then begin
  181.       if (csDesigning in ComponentState) and (Owner <> nil) then
  182.         CreateField(FieldDefs.Items[I], Owner)
  183.       else
  184.         CreateField(FieldDefs.Items[I], Self);
  185.     end;
  186.   end;
  187. end;
  188.  
  189. procedure TMemoryTable.DeleteCurrentRecord;
  190. var
  191.   CurRecNo, CurRec: Longint;
  192.   Buffer: Pointer;
  193.   iFldCount: Word;
  194.   FieldDescs: PFLDDesc;
  195. begin
  196.   CurRecNo := RecNo;
  197.   iFldCount := FieldDefs.Count;
  198.   FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  199.   try
  200.     Check(DbiGetFieldDescs(Handle, FieldDescs));
  201.     Check(DbiCreateInMemTable(DBHandle, '$InMem$', iFldCount, FieldDescs,
  202.       FMoveHandle));
  203.     try
  204.       DisableControls;
  205.       Buffer := AllocMem(RecordSize);
  206.       try
  207.         First;
  208.         CurRec := 0;
  209.         while not Self.EOF do begin
  210.           Inc(CurRec);
  211.           if CurRec <> CurRecNo then begin
  212.             DbiInitRecord(FMoveHandle, Buffer);
  213.             Self.GetCurrentRecord(Buffer);
  214.             Check(DbiAppendRecord(FMoveHandle, Buffer));
  215.           end;
  216.           Self.Next;
  217.         end;
  218.         FDisableEvents := True;
  219.         try
  220.           Close;
  221.           Open;
  222.           FMoveHandle := nil;
  223.         finally
  224.           FDisableEvents := False;
  225.         end;
  226.       finally
  227.         FreeMem(Buffer, RecordSize);
  228.       end;
  229.     except
  230.       DbiCloseCursor(FMoveHandle);
  231.       FMoveHandle := nil;
  232.       raise;
  233.     end;
  234.     GotoRecord(CurRecNo - 1);
  235.   finally
  236.     if FieldDescs <> nil then
  237.       FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  238.     FMoveHandle := nil;
  239.     EnableControls;
  240.   end;
  241. end;
  242.  
  243. {$IFDEF RX_D3}
  244.  
  245. function TMemoryTable.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
  246. var
  247.   IsBlank: LongBool;
  248.   RecBuf: PChar;
  249. begin
  250.   Result := inherited GetFieldData(Field, Buffer);
  251.   if not Result then begin
  252.     RecBuf := nil;
  253.     case State of
  254.       dsBrowse: if not IsEmpty then RecBuf := ActiveBuffer;
  255.       dsEdit, dsInsert: RecBuf := ActiveBuffer;
  256.       dsCalcFields: RecBuf := CalcBuffer;
  257.     end;
  258.     if RecBuf = nil then Exit;
  259.     with Field do
  260.       if (FieldNo > 0) then begin
  261.         Check(DbiGetField(Handle, FieldNo, RecBuf, nil, IsBlank));
  262.         Result := not IsBlank;
  263.       end;
  264.   end;
  265. end;
  266.  
  267. procedure TMemoryTable.InternalDelete;
  268. begin
  269.   if EnableDelete then DeleteCurrentRecord
  270.   else inherited;
  271. end;
  272.  
  273. function TMemoryTable.Locate(const KeyFields: string;
  274.   const KeyValues: Variant; Options: TLocateOptions): Boolean;
  275. begin
  276.   DoBeforeScroll;
  277.   Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);
  278.   if Result then begin
  279.     DataEvent(deDataSetChange, 0);
  280.     DoAfterScroll;
  281.   end;
  282. end;
  283.  
  284. function TMemoryTable.Lookup(const KeyFields: string; const KeyValues: Variant;
  285.   const ResultFields: string): Variant;
  286. begin
  287.   Result := False;
  288. end;
  289.  
  290. {$ELSE}
  291.  
  292. procedure TMemoryTable.DoBeforeDelete;
  293. begin
  294.   inherited DoBeforeDelete;
  295.   if EnableDelete then begin
  296.     DeleteCurrentRecord;
  297.     DoAfterDelete;
  298.     SysUtils.Abort;
  299.   end;
  300. end;
  301.  
  302. {$ENDIF}
  303.  
  304. procedure TMemoryTable.DoAfterClose;
  305. begin
  306.   if not FDisableEvents then inherited DoAfterClose;
  307. end;
  308.  
  309. procedure TMemoryTable.DoAfterOpen;
  310. begin
  311.   if not FDisableEvents then inherited DoAfterOpen;
  312. end;
  313.  
  314. procedure TMemoryTable.DoBeforeClose;
  315. begin
  316.   if not FDisableEvents then inherited DoBeforeClose;
  317. end;
  318.  
  319. procedure TMemoryTable.DoBeforeOpen;
  320. begin
  321.   if not FDisableEvents then inherited DoBeforeOpen;
  322. end;
  323.  
  324. {$IFDEF RX_D3}
  325.  
  326. procedure TMemoryTable.DoBeforeScroll;
  327. begin
  328.   if not FDisableEvents then inherited DoBeforeScroll;
  329. end;
  330.  
  331. procedure TMemoryTable.DoAfterScroll;
  332. begin
  333.   if not FDisableEvents then inherited DoAfterScroll;
  334. end;
  335.  
  336. {$ENDIF}
  337.  
  338. function TMemoryTable.SupportedFieldType(AType: TFieldType): Boolean;
  339. begin
  340.   Result := not (AType in [ftUnknown {$IFDEF RX_D4}, ftWideString {$ENDIF}
  341.     {$IFDEF RX_D5}, ftOraBlob, ftOraClob, ftVariant, ftInterface, 
  342.     ftIDispatch, ftGuid {$ENDIF}] + ftNonTextTypes);
  343. end;
  344.  
  345. function TMemoryTable.CreateHandle: HDBICur;
  346. var
  347.   I: Integer;
  348. {$IFDEF RX_D4}
  349.   FldDescList: TFieldDescList;
  350.   FieldDescs: PFLDDesc;
  351. {$ELSE}
  352.   FieldDescs: PFLDDesc;
  353. {$ENDIF}
  354.   iFldCount: Cardinal;
  355.   szTblName: DBITBLNAME;
  356. begin
  357.   if (FMoveHandle <> nil) then begin
  358.     Result := FMoveHandle;
  359.     Exit;
  360.   end;
  361.   if FieldCount > 0 then FieldDefs.Clear;
  362.   if FieldDefs.Count = 0 then
  363.     for I := 0 to FieldCount - 1 do begin
  364.       if not SupportedFieldType(Fields[I].DataType) then
  365. {$IFDEF RX_D3}
  366.  {$IFDEF RX_D4}
  367.         DatabaseErrorFmt(SUnknownFieldType, [Fields[I].FieldName]);
  368.  {$ELSE}
  369.         DatabaseErrorFmt(SFieldUnsupportedType, [Fields[I].FieldName]);
  370.  {$ENDIF}
  371. {$ELSE}
  372.         DBErrorFmt(SFieldUnsupportedType, [Fields[I].FieldName]);
  373. {$ENDIF}
  374.       with Fields[I] do
  375.         if not (Calculated {$IFDEF WIN32} or Lookup {$ENDIF}) then
  376.           FieldDefs.Add(FieldName, DataType, Size, Required);
  377.     end;
  378. {$IFNDEF RX_D4}
  379.   FieldDescs := nil;
  380. {$ENDIF}
  381.   iFldCount := FieldDefs.Count;
  382.   SetDBFlag(dbfTable, True);
  383.   try
  384.     if TableName = '' then
  385.       AnsiToNative(Locale, '$RxInMem$', szTblName, SizeOf(szTblName) - 1)
  386.     else
  387.       AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
  388. {$IFDEF RX_D4}
  389.     SetLength(FldDescList, iFldCount);
  390.     FieldDescs := BDE.PFLDDesc(FldDescList);
  391. {$ELSE}
  392.     FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  393. {$ENDIF}
  394.     for I := 0 to FieldDefs.Count - 1 do begin
  395.       with FieldDefs[I] do
  396. {$IFDEF RX_D4}
  397.         EncodeFieldDesc(FldDescList[I], Name, DataType, Size, Precision);
  398. {$ELSE}
  399.         EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name, DataType, Size);
  400. {$ENDIF}
  401.     end;
  402.     Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs, nil, nil,
  403.       FieldDescs {$IFDEF WIN32}, False {$ENDIF}));
  404.     Check(DbiCreateInMemTable(DBHandle, szTblName, iFldCount, FieldDescs,
  405.       Result));
  406.   finally
  407. {$IFNDEF RX_D4}
  408.     if FieldDescs <> nil then FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  409. {$ENDIF}
  410.     SetDBFlag(dbfTable, False);
  411.   end;
  412. end;
  413.  
  414. procedure TMemoryTable.CreateTable;
  415. begin
  416.   CheckInactive;
  417.   Open;
  418. end;
  419.  
  420. procedure TMemoryTable.DeleteTable;
  421. begin
  422.   CheckBrowseMode;
  423.   Close;
  424. end;
  425.  
  426. procedure TMemoryTable.EmptyTable;
  427. begin
  428.   if Active then begin
  429.     CheckBrowseMode;
  430.     DisableControls;
  431.     FDisableEvents := True;
  432.     try
  433.       Close;
  434.       Open;
  435.     finally
  436.       FDisableEvents := False;
  437.       EnableControls;
  438.     end;
  439.   end;
  440. end;
  441.  
  442. procedure TMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  443.   const Name: string; DataType: TFieldType; Size
  444.   {$IFDEF RX_D4}, Precision {$ENDIF}: Word);
  445. begin
  446.   with FieldDesc do begin
  447.     FillChar(szName, SizeOf(szName), 0);
  448.     AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  449.     iFldType := FieldLogicMap(DataType);
  450.     iSubType := FieldSubtypeMap(DataType);
  451. {$IFDEF WIN32}
  452.     if iSubType = fldstAUTOINC then iSubType := 0;
  453. {$ENDIF WIN32}
  454.     case DataType of
  455. {$IFDEF RX_D4}
  456.       ftString, ftFixedChar, ftBytes, ftVarBytes, ftBlob..ftTypedBinary:
  457. {$ELSE}
  458.       ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic
  459.       {$IFDEF WIN32}, ftFmtMemo, ftParadoxOle, ftDBaseOle,
  460.       ftTypedBinary {$ENDIF}:
  461. {$ENDIF}
  462.         iUnits1 := Size;
  463.       ftBCD:
  464.         begin
  465. {$IFDEF RX_D4}
  466.           { Default precision is 32, Size = Scale }
  467.           if (Precision > 0) and (Precision <= 32) then iUnits1 := Precision
  468.           else iUnits1 := 32;
  469. {$ELSE}
  470.           iUnits1 := 32;
  471. {$ENDIF}
  472.           iUnits2 := Size;  {Scale}
  473.         end;
  474.     end;
  475.   end;
  476. end;
  477.  
  478. {$IFDEF WIN32}
  479. function TMemoryTable.GetRecordCount: {$IFNDEF RX_D3} Longint {$ELSE} Integer {$ENDIF};
  480. begin
  481.   if State = dsInactive then _DBError(SDataSetClosed);
  482.   Check(DbiGetRecordCount(Handle, Result));
  483. end;
  484. {$ENDIF WIN32}
  485.  
  486. procedure TMemoryTable.SetRecNo(Value: {$IFDEF RX_D3} Integer {$ELSE} Longint {$ENDIF});
  487. var
  488.   Rslt: DBIResult;
  489. begin
  490.   CheckBrowseMode;
  491.   UpdateCursorPos;
  492.   Rslt := DbiSetToSeqNo(Handle, Value);
  493.   if Rslt = DBIERR_EOF then Last
  494.   else if Rslt = DBIERR_BOF then First
  495.   else begin
  496.     Check(Rslt);
  497.     Resync([rmExact, rmCenter]);
  498.   end;
  499. end;
  500.  
  501. {$IFDEF RX_D3}
  502. function TMemoryTable.GetRecNo: Integer;
  503. {$ELSE}
  504. function TMemoryTable.GetRecordNumber: Longint;
  505. {$ENDIF}
  506. var
  507.   Rslt: DBIResult;
  508. begin
  509.   Result := -1;
  510.   if State in [dsBrowse, dsEdit] then begin
  511.     UpdateCursorPos;
  512.     Rslt := DbiGetSeqNo(Handle, Result);
  513.     if (Rslt = DBIERR_EOF) or (Rslt = DBIERR_BOF) then Exit
  514.     else Check(Rslt);
  515.   end;
  516. end;
  517.  
  518. procedure TMemoryTable.GotoRecord(RecordNo: Longint);
  519. begin
  520.   RecNo := RecordNo;
  521. end;
  522.  
  523. {$IFDEF RX_D3}
  524. function TMemoryTable.IsSequenced: Boolean;
  525. begin
  526.   Result := not Filtered;
  527. end;
  528. {$ENDIF RX_D3}
  529.  
  530. procedure TMemoryTable.SetFieldValues(const FieldNames: array of string;
  531.   const Values: array of const);
  532. var
  533.   I: Integer;
  534.   Pos: Longint;
  535. begin
  536.   Pos := RecNo;
  537.   DisableControls;
  538.   try
  539.     First;
  540.     while not EOF do begin
  541.       Edit;
  542.       for I := 0 to Max(High(FieldNames), High(Values)) do
  543.         FieldByName(FieldNames[I]).AssignValue(Values[I]);
  544.       Post;
  545.       Next;
  546.     end;
  547.     GotoRecord(Pos);
  548.   finally
  549.     EnableControls;
  550.   end;
  551. end;
  552.  
  553. procedure TMemoryTable.SetTableName(const Value: TFileName);
  554. begin
  555.   CheckInactive;
  556.   FTableName := Value;
  557.   DataEvent(dePropertyChange, 0);
  558. end;
  559.  
  560. end.
  561.