+ LookupField implementation from Alexandrov Alexandru

git-svn-id: trunk@710 -

fcl/db/dataset.inc

@@ -88,23 +88,32 @@ begin
   for i := 0 to Fields.Count - 1 do
     with Fields[i] do begin
       if Binding then begin
-          if FieldKind in [fkCalculated, fkLookup] then begin
-            FFieldNo := -1;
-            FOffset := FCalcFieldsSize;
-            Inc(FCalcFieldsSize, DataSize + 1);
-          end else begin
-            FieldDef := nil;
-            FieldIndex := FieldDefs.IndexOf(Fields[i].FieldName);
-            if FieldIndex <> -1 then begin
-              FieldDef := FieldDefs[FieldIndex];
-              FFieldNo := FieldDef.FieldNo;
-              if IsBlob then begin
-                FSize := FieldDef.Size;
-                FOffset := FBlobFieldCount;
-                Inc(FBlobFieldCount);
-              end;
-            end else FFieldNo := FieldIndex;
-          end;
+        if FieldKind in [fkCalculated, fkLookup] then begin
+          FFieldNo := -1;
+          FOffset := FCalcFieldsSize;
+          Inc(FCalcFieldsSize, DataSize + 1);
+          if FieldKind in [fkLookup] then begin
+            if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
+               (FLookupResultField = '') or (FKeyFields = '')) then
+              DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
+            FFields.CheckFieldNames(FKeyFields);
+            FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
+            FLookupDataSet.FieldByName(FLookupResultField);
+            if FLookupCache then RefreshLookupList;
+          end
+        end else begin
+          FieldDef := nil;
+          FieldIndex := FieldDefs.IndexOf(Fields[i].FieldName);
+          if FieldIndex <> -1 then begin
+            FieldDef := FieldDefs[FieldIndex];
+            FFieldNo := FieldDef.FieldNo;
+            if IsBlob then begin
+              FSize := FieldDef.Size;
+              FOffset := FBlobFieldCount;
+              Inc(FBlobFieldCount);
+            end;
+          end else FFieldNo := FieldIndex;
+        end;
       end else FFieldNo := 0;;
     end;
 end;
@@ -129,7 +138,7 @@ begin
     ClearCalcFields(CalcBuffer);
     for I := 0 to Fields.Count - 1 do
       with Fields[I] do
-        if FieldKind = fkLookup then {CalcLookupValue};
+        if FieldKind = fkLookup then CalcLookupValue;
   end;
   DoOnCalcFields;
 end;
@@ -1006,7 +1015,7 @@ end;
 Function TDataset.TempBuffer: PChar;
 
 begin
-  //!! To be implemented
+  Result := FBuffers[FRecordCount];
 end;
 
 Procedure TDataset.UpdateIndexDefs;
@@ -1868,16 +1877,42 @@ begin
   FBuffers[0]:=TempBuf;
 end;
 
-function TDataset.GetFieldValues(Fieldname : string) : string;
+function TDataset.GetFieldValues(Fieldname: string): Variant;
 
+var i: Integer;
+    FieldList: TList;
 begin
-  result := findfield(Fieldname).asstring;
+  if Pos(';', FieldName) <> 0 then begin
+    FieldList := TList.Create;
+    try
+      GetFieldList(FieldList, FieldName);
+      Result := VarArrayCreate([0, FieldList.Count - 1], varVariant);
+      for i := 0 to FieldList.Count - 1 do
+        Result[i] := TField(FieldList[i]).Value;
+    finally
+      FieldList.Free;
+    end;
+  end else
+    Result := FieldByName(FieldName).Value
 end;
 
-procedure TDataset.SetFieldValues(Fieldname : string;value : string);
+procedure TDataset.SetFieldValues(Fieldname: string; Value: Variant);
 
+var i: Integer;
+    FieldList: TList;
 begin
-  findfield(Fieldname).asstring := value;
+  if Pos(';', FieldName) <> 0 then
+  begin
+    FieldList := TList.Create;
+    try
+      GetFieldList(FieldList, FieldName);
+      for i := 0 to FieldList.Count - 1 do
+        TField(FieldList[i]).Value := Value[i];
+    finally
+      FieldList.Free;
+    end;
+  end else
+    FieldByName(FieldName).Value := Value;
 end;
 
 Function TDataset.Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean;

fcl/db/db.pp

@@ -126,8 +126,8 @@ type
     procedure SetPrecision(const AValue: Longint);
     procedure SetSize(const AValue: Word);
   protected
-    function GetDisplayName: string;
-    procedure SetDisplayName(const AValue: string);
+    function GetDisplayName: string; override;
+    procedure SetDisplayName(const AValue: string); override;
   public
     constructor Create(AOwner: TFieldDefs; const AName: string;
       ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Longint);
@@ -189,6 +189,25 @@ type
   TFieldRef = ^TField;
   TFieldChars = set of Char;
 
+  PLookupListRec = ^TLookupListRec;
+  TLookupListRec = record
+    Key: Variant;
+    Value: Variant;
+  end;
+
+  { TLookupList }
+
+  TLookupList = class(TObject)
+  private
+    FList: TList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Add(const AKey, AValue: Variant);
+    procedure Clear;
+    function ValueOfKey(const AKey: Variant): Variant;
+  end;
+
   { TField }
 
   TField = class(TComponent)
@@ -218,6 +237,7 @@ type
     FLookupDataSet : TDataSet;
     FLookupKeyfields : String;
     FLookupresultField : String;
+    FLookupList: TLookupList;
     FOffset : Word;
     FOnChange : TFieldNotifyEvent;
     FOnGetText: TFieldGetTextEvent;
@@ -243,6 +263,8 @@ type
     procedure SetReadOnly(const AValue: Boolean);
     procedure SetVisible(const AValue: Boolean);
     function IsDisplayStored : Boolean;
+    function GetLookupList: TLookupList;
+    procedure CalcLookupValue;
   protected
     function AccessError(const TypeName: string): EDatabaseError;
     procedure CheckInactive;
@@ -296,6 +318,7 @@ type
     function GetData(Buffer: Pointer): Boolean;
     class function IsBlob: Boolean; virtual;
     function IsValidChar(InputChar: Char): Boolean; virtual;
+    procedure RefreshLookupList;
     procedure SetData(Buffer: Pointer);
     procedure SetFieldType(AValue: TFieldType); virtual;
     procedure Validate(Buffer: Pointer);
@@ -327,6 +350,7 @@ type
     property Value: variant read GetAsVariant write SetAsVariant;
     property OldValue: variant read GetOldValue;
     property ProviderFlags : TProviderFlags read FProviderFlags write FProviderFlags;
+    property LookupList: TLookupList read GetLookupList;
   published
     property AlignMent : TAlignMent Read FAlignMent write SetAlignment default taLeftJustify;
     property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
@@ -988,7 +1012,7 @@ type
     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
     function  GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
     Function  GetfieldCount : Integer;
-    function  GetFieldValues(fieldname : string) : string; virtual;
+    function  GetFieldValues(fieldname : string) : Variant; virtual;
     function  GetIsIndexField(Field: TField): Boolean; virtual;
     function  GetNextRecords: Longint; virtual;
     function  GetNextRecord: Boolean; virtual;
@@ -1013,7 +1037,7 @@ type
     procedure SetFilterOptions(Value: TFilterOptions); virtual;
     procedure SetFilterText(const Value: string); virtual;
     procedure SetFound(const Value: Boolean);
-    procedure SetFieldValues(fieldname : string;value : string); virtual;
+    procedure SetFieldValues(fieldname: string; Value: Variant); virtual;
     procedure SetModified(Value: Boolean);
     procedure SetName(const Value: TComponentName); override;
     procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
@@ -1128,7 +1152,7 @@ type
     property RecordSize: Word read GetRecordSize;
     property State: TDataSetState read FState;
     property Fields : TFields read FFieldList;
-    property FieldValues[fieldname : string] : string read GetFieldValues write SetFieldValues; default;
+    property FieldValues[fieldname : string] : Variant read GetFieldValues write SetFieldValues; default;
     property Filter: string read FFilterText write SetFilterText;
     property Filtered: Boolean read FFiltered write SetFiltered default False;
     property FilterOptions: TFilterOptions read FFilterOptions write FFilterOptions;
@@ -2010,6 +2034,50 @@ begin
   //!! To be implemented
 end;
 
+{ TLookupList }
+
+constructor TLookupList.Create;
+
+begin
+  FList := TList.Create;
+end;
+
+destructor TLookupList.Destroy;
+
+begin
+  if FList <> nil then Clear;
+  FList.Free;
+  inherited Destroy;
+end;
+
+procedure TLookupList.Add(const AKey, AValue: Variant);
+
+var LookupRec: PLookupListRec;
+begin
+  New(LookupRec);
+  LookupRec^.Key := AKey;
+  LookupRec^.Value := AValue;
+  FList.Add(LookupRec);
+end;
+
+procedure TLookupList.Clear;
+var i: integer;
+begin
+  for i := 0 to FList.Count - 1 do Dispose(PLookupListRec(FList[i]));
+  FList.Clear;
+end;
+
+function TLookupList.ValueOfKey(const AKey: Variant): Variant;
+
+var I: Integer;
+begin
+  Result := Null;
+  if VarIsNull(AKey) then Exit;
+  i := FList.Count - 1;
+  while (i > 0) And (PLookupListRec(FList.Items[I])^.Key <> AKey) do Dec(i);
+  if i >= 0 then Result := PLookupListRec(FList.Items[I])^.Value;
+end;
+
 {$i dataset.inc}
 {$i fields.inc}
 {$i datasource.inc}

fcl/db/dbconst.pp

@@ -72,6 +72,7 @@ Const
   SInvalidCalcType         = 'Field ''%s'' cannot be a calculated or lookup field';
   SDuplicateName           = 'Duplicate name ''%s'' in %s';
   SNoParseSQL              = '%s is only possible if ParseSQL is True';
+  SLookupInfoError         = 'Lookup information for field ''%s'' is incomplete';
 
 Implementation
 

fcl/db/fields.inc

@@ -332,6 +332,7 @@ begin
     if Assigned(FFields) then
       FFields.Remove(Self);
     end;
+  FLookupList.Free;
   Inherited Destroy;
 end;
 
@@ -587,6 +588,22 @@ begin
   Result:=(DisplayLabel<>FieldName);
 end;
 
+function TField.GetLookupList: TLookupList;
+begin
+  if not Assigned(FLookupList) then
+    FLookupList := TLookupList.Create;
+  Result := FLookupList;
+end;
+
+procedure TField.CalcLookupValue;
+begin
+  if FLookupCache then
+    Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
+  else if (FLookupDataSet <> nil) and FLookupDataSet.Active then
+    Value := FLookupDataSet.Lookup(FLookupKeyFields,
+      FDataSet.FieldValues[FKeyFields], FLookupResultField);
+end;
+
 function TField.getIndex : longint;
 
 begin
@@ -651,10 +668,41 @@ begin
   Result:=InputChar in FValidChars;
 end;
 
+procedure TField.RefreshLookupList;
+var SaveActive: Boolean;
+begin
+  if (FLookupDataSet <> nil) And (FLookupKeyFields <> '') And
+     (FlookupResultField <> '') And (FKeyFields <> '') then begin
+    SaveActive := FLookupDataSet.Active;
+    with FLookupDataSet do
+    try
+      Active := True;
+      FFields.CheckFieldNames(FLookupKeyFields);
+      FieldByName(FLookupResultField);
+      LookupList.Clear;
+      DisableControls;
+      try
+        First;
+        while not Eof do begin
+          FLookupList.Add(FieldValues[FLookupKeyFields],
+            FieldValues[FLookupResultField]);
+          Next;
+        end;
+      finally
+        EnableControls;
+      end;
+    finally
+      Active := SaveActive;
+    end;
+  end;
+end;
+
 procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
 
 begin
   Inherited Notification(AComponent,Operation);
+  if (Operation = opRemove) and (AComponent = FLookupDataSet) then
+    FLookupDataSet := nil;
 end;
 
 procedure TField.PropertyChanged(LayoutAffected: Boolean);
@@ -2400,7 +2448,7 @@ begin
   T:=Value;
   Repeat
     I:=Pos(T,';');
-    If I=0 Then I:=Length(T);
+    If I=0 Then I:=Length(T)+1;
     S:=Copy(T,1,I-1);
     Delete(T,1,I);
     // Will raise an error if no such field...