unit uDACDSDataTable; {----------------------------------------------------------------------------} { Data Abstract Library - Core Library } { } { compiler: Delphi 6 and up } { platform: Win32 } { } { (c)opyright RemObjects Software. all rights reserved. } { } { Using this code requires a valid license of the Data Abstract } { which can be obtained at http://www.remobjects.com. } {----------------------------------------------------------------------------} {$I DataAbstract.inc} interface uses Classes, DB, uDAInterfaces, uDADataTable, DBClient; const DAFormatToCDSFormat : array[TDANativeDataFormat] of TDataPacketFormat = (dfBinary, dfXML); type TDACDSDataTable = class; { IDAClonedCursorsSupport } IDAClonedCursorsSupport = interface ['{A43A70A2-7438-4C21-B2E2-A5212082EFD0}'] function GetCloneSource : TDACDSDataTable; safecall; procedure CloneCursor(Source : TDACDSDataTable); safecall; function GetUsingClonedCursor : boolean; safecall; property CloneSource : TDACDSDataTable read GetCloneSource; property UsingClonedCursor : boolean read GetUsingClonedCursor; end; { TDAClientdataset } TDAClientdataset = class(TClientDataset, IDADataTableDataset) private function GetActive: boolean; protected function GetDataTable: TDADataTable; safecall; procedure InternalRefresh; override; function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override; public {$IFDEF DELPHI7UP} procedure GetFieldNames(List: TStrings); override; {$ENDIF} published property Active: boolean read GetActive; end; { TDACDSDataTable } TDACDSDataTable = class(TDADataTable, IDAClonedCursorsSupport, IDARangeController, IDANativeDatasetStreaming,IDASimpleClonedCursorsSupport) private fMasterSource : TDADataSource; fClientDataset: TClientDataSet; fCloneSource : TDACDSDataTable; fWasReadonly : Boolean; fOldValues : array of Variant; protected function GetCurrRecId: integer; override; procedure SetCurrRecId(const Value: integer); override; function GetAutoIncs: TAutoIncArray; override; procedure SetAutoIncs(const Value: TAutoIncArray); override; function GetDatasetClass: TDatasetClass; override; procedure CreateInternalFields(aDataset: TDataset; someFieldDefinitions: TDAFieldCollection); override; procedure DoSort(const FieldNames: array of string; const Directions: array of TDASortDirection); override; procedure DoBeforeOpenDataset; override; procedure DoAfterCloseDataset; override; procedure SetMasterSource(const Value: TDADataSource); override; function GetMasterSource: TDADataSource; override; procedure SetDetailsFields(const Value: string); override; procedure SetMasterFields(const Value: string); override; function GetDetailFields: string; override; function GetMasterFields: string; override; function GetIndexDefs: TIndexDefs; procedure SetIndexDefs(const Value: TIndexDefs); function GetIndexName: string; procedure SetIndexName(const Value: string); function GetFilter: string; override; function GetFiltered: boolean; override; procedure SetFilter(const Value: string); override; procedure SetFiltered(const Value: boolean); override; function GetReadOnly: boolean; override; procedure SetReadOnly(const Value: boolean); override; { Overrides to support IDAClonedCursorsSupport } procedure InternalAfterPost(Sender: TDataset); override; procedure InternalBeforeInsert(Sender: TDataset); override; procedure InternalBeforeDelete(Sender: TDataset); override; procedure InternalBeforeEdit(Sender: TDataset); override; procedure DoBeforeCloseDataset; override; public constructor Create(aOwner: TComponent); override; function ApplyUpdates(RefetchAll: boolean = FALSE): boolean; override; procedure FindNearest(const KeyValues: array of const); { IDASimpleClonedCursorsSupport } function GetSimpleCloneSource : TObject; { IDAClonedCursorsSupport } procedure CloneCursor(Source : TDACDSDataTable); safecall; function GetCloneSource : TDACDSDataTable; safecall; function GetUsingClonedCursor : boolean; safecall; { IDANativeDatasetStreaming } procedure NativeSaveToFile(const aFileName : string; DataFormat : TDANativeDataFormat = ndfBinary); procedure NativeLoadFromFile(const aFileName : string); procedure NativeSaveToStream(aStream : TStream; DataFormat : TDANativeDataFormat = ndfBinary); procedure NativeLoadFromStream(aStream : TStream); { IDARangeController } procedure ApplyRange; safecall; procedure CancelRange; safecall; procedure SetRange(const StartValues, EndValues: array of const); safecall; procedure EditRangeEnd; safecall; procedure EditRangeStart; safecall; procedure SetRangeEnd; safecall; procedure SetRangeStart; safecall; property CloneSource : TDACDSDataTable read GetCloneSource; property UsingClonedCursor : boolean read GetUsingClonedCursor; procedure DisableConstraints; override; safecall; procedure EnableConstraints; override; safecall; procedure CheckProperties(ACheckRemoteFetching: Boolean=False); override; published property IndexDefs: TIndexDefs read GetIndexDefs write SetIndexDefs; property IndexName: string read GetIndexName write SetIndexName; end; // Table for quick CRC Calculations. Used to generate unique index names when sorting const crctable : array [0..255] of cardinal = ( $00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D ); function CRC(S : String):LongInt; implementation uses Variants, SysUtils, uDAClasses; { TDACDSDataTable } constructor TDACDSDataTable.Create(aOwner: TComponent); begin inherited; fClientDataset := TClientDataSet(Dataset); fClientDataset.FetchOnDemand := FALSE; fClientDataset.FilterOptions := [foCaseInsensitive]; end; procedure TDACDSDataTable.CreateInternalFields(aDataset: TDataset; someFieldDefinitions: TDAFieldCollection); begin inherited; // Creates the dataset if not MasterLink.Active then begin // This should actually never happen since its mutually exclusive with IndexFieldNames... if (fClientDataset.IndexName<>'') then fClientDataset.IndexName := ''; end; fClientDataset.CreateDataSet; //fClientDataset.LogChanges := FALSE; { Unfortunately a bug in the CDS provents us to disable the log. Tables with multiple blob fields behave weird and lose data otherwise. The Issue has been reported to Borland. } end; // CRC routine in ASM. // NOTE: This routine strips the signed bit from the CRC. // Written and posted on Google by Clifford Hammerschmidt // http://www.engr.uvic.ca/~chammers/ // http://www.ultranet.ca/chcc/ function CRC(S : String):LongInt; var Len,crc : LongInt; K : PChar; begin Len := Length(S); K := PChar(S); asm mov dword ptr [crc],$ffffffff @@2: dec dword ptr [len] cmp dword ptr [len],$FFFFFFFF je @@1 mov eax,dword ptr [K] movsx eax,byte ptr [eax] mov ecx,dword ptr [crc] sar ecx,$18 xor eax,ecx and eax,$000000ff mov eax,dword ptr [crctable+eax*$4] mov ecx,dword ptr [crc] shl ecx,$08 xor eax,ecx mov dword ptr [crc],eax inc dword ptr [K] jmp @@2 @@1: // NOTE: From here on the asm is optional... mov eax,dword ptr [crc] not eax // Next line strips signed bit... and eax,$7fffffff mov dword ptr [crc],eax end; Result := crc; end; procedure TDACDSDataTable.DoSort(const FieldNames: array of string; const Directions: array of TDASortDirection); const DirectionStr: array[TDASortDirection] of string = ('ASC', 'DESC'); var ascfields, descfields, idxname: string; i: integer; idx: TIndexDef; begin with fClientDataset do begin if (Length(FieldNames) = 0) then begin IndexName := ''; Exit; end; idxname := ''; for i := 0 to Length(FieldNames) - 1 do idxname := idxname + FieldNames[i] + '_' + DirectionStr[Directions[i]]; idxname := 'IDX'+IntToStr(CRC(idxname)); idx := TDefCollection(IndexDefs).Find(idxname) as TIndexDef; if (idx = nil) then begin ascfields := ''; descfields := ''; for i := 0 to Length(Directions) - 1 do begin ascfields := ascfields + FieldNames[i] + ';'; //<-- IDX.Fields must include ALL Fieldnames if Directions[i] = sdDescending then descfields := descfields + FieldNames[i] + ';'; end; idx := fClientDataset.IndexDefs.AddIndexDef; idx.Name := idxname; idx.DescFields := descfields; idx.Fields := ascfields; end; IndexName := idxname; end; end; function TDACDSDataTable.GetDatasetClass: TDatasetClass; begin result := TDAClientDataset; end; function TDACDSDataTable.GetMasterSource: TDADataSource; begin result := fMasterSource; end; procedure TDACDSDataTable.DoAfterCloseDataset; begin inherited; fClientDataset.Data := Null; fCloneSource := NIL; end; function TDACDSDataTable.GetFilter: string; begin result := fClientDataset.Filter end; ////////////// procedure TDACDSDataTable.DoBeforeOpenDataset; begin inherited; // This helps prevending a design time problem which results in DetailFields being reset // whenever something is wrong or the dataset cannot be open properly // Keep in this orders!!! { fClientDataset.IndexFieldNames := fDetailFields; fClientDataset.MasterFields := fMasterFields; fClientDataset.MasterSource := fMasterSource;} end; procedure TDACDSDataTable.SetMasterSource(const Value: TDADataSource); begin fClientDataset.MasterSource := Value; fMasterSource := Value; inherited SetMasterSource(Value); end; procedure TDACDSDataTable.SetMasterFields(const Value: string); begin fClientDataset.MasterFields := Value; inherited; //fMasterFields := Value; end; procedure TDACDSDataTable.SetDetailsFields(const Value: string); begin fClientDataset.IndexFieldNames := Value //fDetailFields := Value; end; function TDACDSDataTable.GetDetailFields: string; begin result := fClientDataset.IndexFieldNames //result := fDetailFields end; function TDACDSDataTable.GetMasterFields: string; begin result := fClientDataset.MasterFields //result := fMasterFields end; /////////// function TDACDSDataTable.GetFiltered: boolean; begin result := fClientDataset.Filtered end; procedure TDACDSDataTable.SetFilter(const Value: string); begin fClientDataset.Filter := Value end; procedure TDACDSDataTable.SetFiltered(const Value: boolean); begin fClientDataset.Filtered := Value end; function TDACDSDataTable.GetIndexDefs: TIndexDefs; begin result := fClientDataset.IndexDefs end; procedure TDACDSDataTable.SetIndexDefs(const Value: TIndexDefs); begin fClientDataset.IndexDefs.Assign(Value); end; function TDACDSDataTable.GetIndexName: string; begin result := fClientDataset.IndexName end; procedure TDACDSDataTable.SetIndexName(const Value: string); begin fClientDataset.IndexName := Value end; function TDACDSDataTable.GetReadOnly: boolean; begin result := fClientDataset.ReadOnly end; procedure TDACDSDataTable.SetReadOnly(const Value: boolean); begin fClientDataset.ReadOnly := Value end; procedure TDACDSDataTable.CloneCursor(Source: TDACDSDataTable); var i: integer; begin if Active then raise Exception.Create('Datatable is already open'); try fCloneSource := Source; Fields.Clear; Fields.Assign(Source.Fields); // Lookup fields are not cloned by the CDS. We must remove them for i := (Fields.Count-1) downto 0 do if Fields[i].Lookup then Fields.Delete(i); // Proceeds fClientDataset.CloneCursor(Source.Dataset as TClientDataset, False); RecIDField := fClientDataset.FieldByName(RecIDFieldName) as TIntegerField; RecIDField.Visible := FALSE; Fields.Bind(fClientDataset); // Prepares the delta Delta := Source.Delta; // Finishes to prepare the internal dataset (descendant might need additional customization and might not be open) DoBeforeOpenDataset; if not Dataset.Active then Dataset.Open; DoAfterOpenDataset; except // Restores the previous state fCloneSource := NIL; Delta := NIL; raise; end; end; procedure TDACDSDataTable.ApplyRange; begin fClientDataset.ApplyRange end; procedure TDACDSDataTable.CancelRange; begin fClientDataset.CancelRange end; procedure TDACDSDataTable.EditRangeEnd; begin fClientDataset.EditRangeEnd end; procedure TDACDSDataTable.EditRangeStart; begin fClientDataset.EditRangeStart end; procedure TDACDSDataTable.SetRange(const StartValues, EndValues: array of const); begin fClientDataset.SetRange(StartValues, EndValues); end; procedure TDACDSDataTable.SetRangeEnd; begin fClientDataset.SetRangeEnd end; procedure TDACDSDataTable.SetRangeStart; begin fClientDataset.SetRangeStart end; procedure TDACDSDataTable.InternalBeforeDelete(Sender: TDataset); begin if UsingClonedCursor and DeltaInitialized then Delta.AssignDataTable(Self); try inherited; finally if UsingClonedCursor and HasDelta then Delta.AssignDataTable(fCloneSource); end; end; procedure TDACDSDataTable.InternalBeforeEdit(Sender: TDataset); var i: Integer; begin if UsingClonedCursor and DeltaInitialized then Delta.AssignDataTable(Self); try inherited; SetLength(fOldValues, Dataset.Fields.Count); for i := 0 to Length(fOldValues) -1 do fOldValues[i] := Dataset.Fields[i].Value; except // Somehow the edit failed, so we restore the original data table to the delta if UsingClonedCursor and HasDelta then Delta.AssignDataTable(fCloneSource); raise; end; end; procedure TDACDSDataTable.InternalBeforeInsert(Sender: TDataset); var i: Integer; begin if UsingClonedCursor and DeltaInitialized then Delta.AssignDataTable(Self); try inherited; SetLength(fOldValues, FieldCount); for i := 0 to Length(fOldValues) -1 do fOldValues[i] := null; except // Somehow the insert failed, so we restore the original data table to the delta if UsingClonedCursor and HasDelta then Delta.AssignDataTable(fCloneSource); raise; end; end; procedure TDACDSDataTable.InternalAfterPost(Sender: TDataset); begin try inherited; finally // Finally restores the original datatable to the delta if UsingClonedCursor and DeltaInitialized then Delta.AssignDataTable(fCloneSource); end; end; function TDACDSDataTable.GetCloneSource: TDACDSDataTable; begin result := fCloneSource end; procedure TDACDSDataTable.DoBeforeCloseDataset; begin if (fCloneSource<>NIL) then Fields.Clear; inherited; end; procedure TDACDSDataTable.NativeLoadFromFile(const aFileName: string); var fs : TFileStream; begin fs := TFileStream.Create(aFileName, fmOpenRead+fmShareDenyWrite); try NativeLoadFromStream(fs); finally fs.Free; end; end; procedure TDACDSDataTable.NativeSaveToFile(const aFileName: string; DataFormat: TDANativeDataFormat); var fs : TFileStream; begin fs := TFileStream.Create(aFileName, fmCreate); try NativeSaveToStream(fs, DataFormat); finally fs.Free; end; end; procedure TDACDSDataTable.NativeLoadFromStream(aStream : TStream); var oldrf : boolean; ls : TDASchema; begin oldrf := RemoteFetchEnabled; ls := LocalSchema; try RemoteFetchEnabled := FALSE; ls := NIL; if not Active then Active := TRUE else if DeltaInitialized then Delta.Clear; fClientDataset.LoadFromStream(aStream); finally RemoteFetchEnabled := oldrf; LocalSchema := ls; end; end; procedure TDACDSDataTable.NativeSaveToStream(aStream : TStream; DataFormat: TDANativeDataFormat); begin fClientDataset.SaveToStream(aStream, DAFormatToCDSFormat[DataFormat]); end; function TDACDSDataTable.ApplyUpdates(RefetchAll: boolean): boolean; begin if (fCloneSource<>NIL) then result := fCloneSource.ApplyUpdates(RefetchAll) else result := inherited ApplyUpdates(RefetchAll); end; function TDACDSDataTable.GetUsingClonedCursor: boolean; begin result := fCloneSource<>NIL end; function TDACDSDataTable.GetCurrRecId: integer; begin if CloneSource = nil then result := inherited GetCurrRecId else result := CloneSource.CurrRecId; end; procedure TDACDSDataTable.SetCurrRecId(const Value: integer); begin if CloneSource = nil then inherited SetCurrRecId(Value) else CloneSource.CurrRecId := Value end; function TDACDSDataTable.GetAutoIncs: TAutoIncArray; begin if CloneSource = nil then result := inherited GetAutoIncs else result := CloneSource.AutoIncs; end; procedure TDACDSDataTable.SetAutoIncs(const Value: TAutoIncArray); begin if CloneSource = nil then inherited SetAutoIncs(Value) else CloneSource.AutoIncs := Value end; procedure TDACDSDataTable.DisableConstraints; begin fWasReadonly := ReadOnly; ReadOnly := False; fClientDataset.DisableConstraints; end; procedure TDACDSDataTable.EnableConstraints; begin fClientDataset.EnableConstraints; ReadOnly := fWasReadonly; end; procedure TDACDSDataTable.FindNearest(const KeyValues: array of const); begin fClientDataset.FindNearest(KeyValues); end; procedure TDACDSDataTable.CheckProperties(ACheckRemoteFetching: Boolean); begin if (fCloneSource<>NIL) then fCloneSource.CheckProperties else inherited CheckProperties; end; function TDACDSDataTable.GetSimpleCloneSource: TObject; begin Result:=GetCloneSource; end; { TDAClientdataset } function TDAClientdataset.GetActive: boolean; begin result := inherited Active; end; function TDAClientdataset.GetDataTable: TDADataTable; begin result := TDADataTable(Owner); end; {$IFDEF DELPHI7UP} procedure TDAClientdataset.GetFieldNames(List: TStrings); var i: Integer; begin if (not inherited Active) then begin for i := 0 to TDADataTable(Owner).FieldCount -1 do List.Add(TDADataTable(Owner).Fields[i].Name); exit; end; {$IFDEF DELPHI10UP}{$WARN SYMBOL_DEPRECATED OFF}{$ENDIF} inherited GetFieldNames(List); {$IFDEF DELPHI10UP}{$WARN SYMBOL_DEPRECATED ON}{$ENDIF} end; {$ENDIF} function TDAClientdataset.GetStateFieldValue(State: TDataSetState; Field: TField): Variant; begin if (State = dsOldValue) and (Self.State in [dsEdit, dsInsert]) then Result := TDACDSDataTable(Owner).fOldValues[Field.Index] else result := Inherited GetStateFieldValue(State, Field); end; procedure TDAClientdataset.InternalRefresh; begin // Does nothing end; end.