Merged revisions 710,803,829-830 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@831 -

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;
@@ -480,78 +489,30 @@ begin
   Result:=nil;
 end;
 
+function TDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+
+begin
+  Result := False;
+end;
+
 function TDataSet.GetFieldData(Field: TField; Buffer: Pointer;
   NativeFormat: Boolean): Boolean;
   
-  function ConvertData(Field: TField; Source: TDateTimeRec): TDateTime;
-  var
-    TimeStamp: TTimeStamp;
-  begin
-    case Field.DataType of
-      ftDate:
-        begin
-          TimeStamp.Time := 0;
-          TimeStamp.Date := Source.Date;
-        end;
-      ftTime:
-        begin
-          TimeStamp.Time := Source.Time;
-          TimeStamp.Date := DateDelta;
-        end;
-    else
-      try
-        TimeStamp := MSecsToTimeStamp(Trunc(Source.DateTime));
-      except
-        TimeStamp.Time := 0;
-        TimeStamp.Date := 0;
-      end;
-    end;
-//    Result := TimeStampToDateTime(TimeStamp);
-    Result := (TimeStamp.Date - DateDelta) + (TimeStamp.Time / MSecsPerDay);
-  end;
+begin
+  Result := GetFieldData(Field, Buffer);
+end;
 
-var
-  d: TDateTimeRec;
-begin
-  if NativeFormat then
-    Result := GetFieldData(Field, Buffer) else
-  if Field.DataType in  [ ftDate, ftDateTime, ftTime ] then begin
-    Result := GetFieldData(Field, @d);
-    if Result then
-      TDateTime(Buffer^) := ConvertData(Field, d);
-  end else
-    Result := GetFieldData(Field, Buffer);
+procedure TDataSet.SetFieldData(Field: TField; Buffer: Pointer);
+
+begin
+// empty procedure
 end;
 
 procedure TDataSet.SetFieldData(Field: TField; Buffer: Pointer;
   NativeFormat: Boolean);
 
-  function ConvertData(Field: TField; Data: TDateTime): TDateTimeRec;
-  var
-    TimeStamp: TTimeStamp;
-  begin
-    TimeStamp.Time := Trunc(Frac(Data) * MSecsPerDay);
-    TimeStamp.Date := DateDelta + Trunc(System.Int(Data));
-//    TimeStamp := DateTimeToTimeStamp(Data);
-    case Field.DataType of
-      ftDate: Result.Date := TimeStamp.Date;
-      ftTime: Result.Time := TimeStamp.Time;
-    else
-      Result.DateTime := TimeStampToMSecs(TimeStamp);
-    end;
-  end;
-
-var
-  d: TDateTimeRec;
 begin
-  if NativeFormat then
-    SetFieldData(Field, Buffer)
-  else
-  if Field.DataType in  [ ftDate, ftDateTime, ftTime ] then begin
-    d := ConvertData(Field, TDateTime(Buffer^));
-    SetFieldData(Field, @d);
-  end else
-    SetFieldData(Field, Buffer);
+  SetFieldData(Field, Buffer);
 end;
 
 Function TDataset.GetField (Index : Longint) : TField;
@@ -1003,12 +964,6 @@ begin
     end;
 end;
 
-Function TDataset.TempBuffer: PChar;
-
-begin
-  //!! To be implemented
-end;
-
 Procedure TDataset.UpdateIndexDefs;
 
 begin
@@ -1868,16 +1823,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,14 +1037,13 @@ 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;
     procedure SetRecNo(Value: Longint); virtual;
     procedure SetState(Value: TDataSetState);
     function SetTempState(const Value: TDataSetState): TDataSetState;
-    function TempBuffer: PChar;
     procedure UpdateIndexDefs; virtual;
     property ActiveRecord: Longint read FActiveRecord;
     property CurrentRecord: Longint read FCurrentRecord;
@@ -1038,7 +1061,7 @@ type
     procedure GetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
     function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; virtual; abstract;
     function GetDataSource: TDataSource; virtual;
-    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; virtual; abstract;
+    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; virtual;
     function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; virtual;
     function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
     function GetRecordSize: Word; virtual; abstract;
@@ -1057,7 +1080,7 @@ type
     function IsCursorOpen: Boolean; virtual; abstract;
     procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); virtual; abstract;
     procedure SetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
-    procedure SetFieldData(Field: TField; Buffer: Pointer); overload; virtual; abstract;
+    procedure SetFieldData(Field: TField; Buffer: Pointer); overload; virtual;
     procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; virtual;
   public
     constructor Create(AOwner: TComponent); override;
@@ -1128,7 +1151,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 +2033,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;
 
@@ -557,7 +558,7 @@ begin
       Move (FValueBuffer^,Buffer^ ,DataSize);
     end
   else
-    Result:=FDataset.GetFieldData(Self,Buffer,False);
+    Result:=FDataset.GetFieldData(Self,Buffer);
 end;
 
 function TField.GetDataSize: Word;
@@ -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...

fcl/db/sqldb/mysql/mysql4conn.pas

@@ -243,7 +243,6 @@ procedure TMySQLConnection.PrepareStatement(cursor: TSQLCursor;
 begin
   if assigned(AParams) and (AParams.count > 0) then
     DatabaseError('Parameters (not) yet supported for the MySQL SqlDB connection.',self);
-  ObtainSQLStatementType(cursor,buf);
   With Cursor as TMysqlCursor do
     begin
     FStatement:=Buf;

fcl/db/sqldb/postgres/pqconnection.pp

@@ -381,7 +381,6 @@ var s : string;
     i : integer;
 
 begin
-  ObtainSQLStatementType(cursor,buf);
   with (cursor as TPQCursor) do
     begin
     FPrepared := False;

fcl/db/sqldb/sqldb.pp

@@ -56,6 +56,9 @@ const
 
 { TSQLConnection }
 type
+
+  { TSQLConnection }
+
   TSQLConnection = class (TDatabase)
   private
     FPassword            : string;
@@ -97,11 +100,12 @@ type
     procedure UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string); virtual;
     function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; virtual;
     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; virtual;abstract;
-    Procedure ObtainSQLStatementType(Cursor : TSQLCursor; SQLStr : string);
   public
     property Handle: Pointer read GetHandle;
     destructor Destroy; override;
     property ConnOptions: TConnOptions read FConnOptions;
+    procedure ExecuteDirect(SQL : String); overload; virtual;
+    procedure ExecuteDirect(SQL : String; Transaction : TSQLTransaction); overload; virtual;
   published
     property Password : string read FPassword write FPassword;
     property Transaction : TSQLTransaction read FTransaction write SetTransaction;
@@ -198,7 +202,6 @@ type
     function  GetCanModify: Boolean; override;
     function ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean; override;
     Function IsPrepared : Boolean; virtual;
-    procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; override;
     procedure SetFiltered(Value: Boolean); override;
   public
     procedure Prepare; virtual;
@@ -301,6 +304,41 @@ begin
   inherited Destroy;
 end;
 
+Procedure TSQLConnection.ExecuteDirect(SQL: String);
+
+begin
+  ExecuteDirect(SQL,FTransaction);
+end;
+
+Procedure TSQLConnection.ExecuteDirect(SQL: String; Transaction : TSQLTransaction);
+
+var Cursor : TSQLCursor;
+
+begin
+  if not assigned(Transaction) then
+    DatabaseError(SErrTransactionnSet);
+
+  if not Connected then Open;
+  if not Transaction.Active then Transaction.StartTransaction;
+
+  try
+    Cursor := AllocateCursorHandle;
+
+    SQL := TrimRight(SQL);
+
+    if SQL = '' then
+      DatabaseError(SErrNoStatement);
+
+    Cursor.FStatementType := stNone;
+
+    PrepareStatement(cursor,Transaction,SQL,Nil);
+    execute(cursor,Transaction, Nil);
+    CloseStatement(Cursor);
+  finally;
+    DeAllocateCursorHandle(Cursor);
+  end;
+end;
+
 function TSQLConnection.GetAsSQLText(Field : TField) : string;
 
 begin
@@ -314,54 +352,6 @@ begin
   end; {case}
 end;
 
-Procedure TSQLConnection.ObtainSQLStatementType(Cursor : TSQLCursor; SQLStr : string);
-
-Var
-  L        : Integer;
-  cmt      : boolean;
-  P,PE,PP  : PChar;
-  S        : string;
-
-begin
-  L := Length(SQLstr);
-
-  if L=0 then
-    begin
-    DatabaseError(SErrNoStatement);
-    exit;
-    end;
-
-  P:=Pchar(SQLstr);
-  PP:=P;
-  Cmt:=False;
-  While ((P-PP)<L) do
-    begin
-    if not (P^ in [' ',#13,#10,#9]) then
-      begin
-      if not Cmt then
-        begin
-        // Check for comment.
-        Cmt:=(P^='/') and (((P-PP)<=L) and (P[1]='*'));
-        if not (cmt) then
-          Break;
-        end
-      else
-        begin
-        // Check for end of comment.
-         Cmt:=Not( (P^='*') and (((P-PP)<=L) and (P[1]='/')) );
-        If not cmt then
-          Inc(p);
-        end;
-      end;
-    inc(P);
-    end;
-  PE:=P+1;
-  While ((PE-PP)<L) and (PE^ in ['0'..'9','a'..'z','A'..'Z','_']) do
-   Inc(PE);
-  Setlength(S,PE-P);
-  Move(P^,S[1],(PE-P));
-  Cursor.FStatementType := StrToStatementType(s);
-end;
 
 function TSQLConnection.GetSchemaInfoSQL( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string;
 
@@ -529,12 +519,6 @@ begin
   Result := Assigned(FCursor) and FCursor.FPrepared;
 end;
 
-procedure TSQLQuery.SetFieldData(Field: TField; Buffer: Pointer;
-  NativeFormat: Boolean);
-begin
-  SetFieldData(Field, Buffer);
-end;
-
 Function TSQLQuery.AddFilter(SQLstr : string) : string;
 
 begin
@@ -595,6 +579,9 @@ begin
 
     FSQLBuf := TrimRight(FSQL.Text);
     
+    if FSQLBuf = '' then
+      DatabaseError(SErrNoStatement);
+
     SQLParser(FSQLBuf);
 
     if filtered then