--- ibx/trunk/runtime/IBCustomDataSet.pas 2015/07/18 12:30:52 34 +++ ibx/trunk/runtime/IBCustomDataSet.pas 2016/01/26 14:38:47 35 @@ -120,16 +120,30 @@ type TIBStringField = class(TStringField) private - FInitialised: boolean; + FCharacterSetName: string; + FCharacterSetSize: integer; protected - procedure SetSize(AValue: Integer); override; + function GetDefaultWidth: Longint; override; public - constructor create(AOwner: TComponent); override; + constructor Create(aOwner: TComponent); override; class procedure CheckTypeSize(Value: Integer); override; function GetAsString: string; override; function GetAsVariant: Variant; override; function GetValue(var Value: string): Boolean; procedure SetAsString(const Value: string); override; + property CharacterSetName: string read FCharacterSetName write FCharacterSetName; + property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize; + end; + + { TIBWideStringField } + + TIBWideStringField = class(TWideStringField) + private + FCharacterSetName: string; + FCharacterSetSize: integer; + public + property CharacterSetName: string read FCharacterSetName write FCharacterSetName; + property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize; end; { TIBBCDField } @@ -152,6 +166,48 @@ type property Size default 8; end; + {TIBMemoField} + {Allows us to show truncated text in DBGrids and anything else that uses + DisplayText} + + TIBMemoField = class(TMemoField) + private + FCharacterSetName: string; + FCharacterSetSize: integer; + FDisplayTextAsClassName: boolean; + function GetTruncatedText: string; + protected + function GetDefaultWidth: Longint; override; + procedure GetText(var AText: string; ADisplayText: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property CharacterSetName: string read FCharacterSetName write FCharacterSetName; + property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize; + published + property DisplayTextAsClassName: boolean read FDisplayTextAsClassName + write FDisplayTextAsClassName; + end; + + { TIBWideMemoField } + + TIBWideMemoField = class(TWideMemoField) + private + FCharacterSetName: string; + FCharacterSetSize: integer; + FDisplayTextAsClassName: boolean; + function GetTruncatedText: string; + protected + function GetDefaultWidth: Longint; override; + procedure GetText(var AText: string; ADisplayText: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property CharacterSetName: string read FCharacterSetName write FCharacterSetName; + property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize; + published + property DisplayTextAsClassName: boolean read FDisplayTextAsClassName + write FDisplayTextAsClassName; + end; + TIBDataLink = class(TDetailDataLink) private FDataSet: TIBCustomDataSet; @@ -341,7 +397,6 @@ type procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes); procedure SetUniDirectional(Value: Boolean); procedure RefreshParams; - procedure SQLChanging(Sender: TObject); virtual; function AdjustPosition(FCache: PChar; Offset: DWORD; Origin: Integer): DWORD; procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer; @@ -371,6 +426,8 @@ type procedure InternalRefreshRow; virtual; procedure InternalSetParamsFromCursor; virtual; procedure CheckNotUniDirectional; + procedure SQLChanging(Sender: TObject); virtual; + procedure SQLChanged(Sender: TObject); virtual; (* { IProviderSupport } procedure PSEndTransaction(Commit: Boolean); override; @@ -502,7 +559,7 @@ type procedure RecordModified(Value: Boolean); procedure RevertRecord; procedure Undelete; - procedure ResetParser; + procedure ResetParser; virtual; function HasParser: boolean; { TDataSet support methods } @@ -690,7 +747,7 @@ DefaultFieldClasses: array[TFieldType] o TVarBytesField, { ftVarBytes } TAutoIncField, { ftAutoInc } TBlobField, { ftBlob } - TMemoField, { ftMemo } + TIBMemoField, { ftMemo } TGraphicField, { ftGraphic } TBlobField, { ftFmtMemo } TBlobField, { ftParadoxOle } @@ -698,7 +755,7 @@ DefaultFieldClasses: array[TFieldType] o TBlobField, { ftTypedBinary } nil, { ftCursor } TStringField, { ftFixedChar } - TWideStringField, { ftWideString } + TIBWideStringField, { ftWideString } TLargeIntField, { ftLargeInt } nil, { ftADT } nil, { ftArray } @@ -713,7 +770,7 @@ DefaultFieldClasses: array[TFieldType] o TDateTimeField, {ftTimestamp} TIBBCDField, {ftFMTBcd} nil, {ftFixedWideChar} - TWideMemoField); {ftWideMemo} + TIBWideMemoField); {ftWideMemo} (* TADTField, { ftADT } TArrayField, { ftArray } @@ -730,7 +787,7 @@ DefaultFieldClasses: array[TFieldType] o implementation -uses IBIntf, Variants, FmtBCD; +uses IBIntf, Variants, FmtBCD, LCLProc, LazUTF8; const FILE_BEGIN = 0; FILE_CURRENT = 1; @@ -753,6 +810,110 @@ type NextRelation : TRelationNode; end; + {Extended Field Def for character set info} + + { TIBFieldDef } + + TIBFieldDef = class(TFieldDef) + private + FCharacterSetName: string; + FCharacterSetSize: integer; + published + property CharacterSetName: string read FCharacterSetName write FCharacterSetName; + property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize; + end; + +{ TIBWideMemoField } + +function TIBWideMemoField.GetTruncatedText: string; +begin + Result := GetAsString; + + if Result <> '' then + if DisplayWidth = 0 then + Result := TextToSingleLine(Result) + else + if Length(Result) > DisplayWidth then {Show truncation with elipses} + Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...'; +end; + +function TIBWideMemoField.GetDefaultWidth: Longint; +begin + Result := 128; +end; + +procedure TIBWideMemoField.GetText(var AText: string; ADisplayText: Boolean); +begin + if ADisplayText then + begin + if not DisplayTextAsClassName then + AText := GetTruncatedText + else + inherited GetText(AText, ADisplayText); + end + else + AText := GetAsString; +end; + +constructor TIBWideMemoField.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + BlobType := ftWideMemo; +end; + +{ TIBMemoField } + +function TIBMemoField.GetTruncatedText: string; +begin + Result := GetAsString; + + if Result <> '' then + begin + case CharacterSetSize of + 1: + if DisplayWidth = 0 then + Result := TextToSingleLine(Result) + else + if Length(Result) > DisplayWidth then {Show truncation with elipses} + Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...'; + + {2: case 2 ignored. This should be handled by TIBWideMemo} + + 3, {Assume UNICODE_FSS is really UTF8} + 4: {Include GB18030 - assuming UTF8 routine work for this codeset} + if DisplayWidth = 0 then + Result := ValidUTF8String(TextToSingleLine(Result)) + else + if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses} + Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...'; + end; + end +end; + +function TIBMemoField.GetDefaultWidth: Longint; +begin + Result := 128; +end; + +procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean); +begin + if ADisplayText then + begin + if not DisplayTextAsClassName then + AText := GetTruncatedText + else + inherited GetText(AText, ADisplayText); + end + else + AText := GetAsString; +end; + +constructor TIBMemoField.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + BlobType := ftMemo; +end; + { TIBControlLink } destructor TIBControlLink.Destroy; @@ -784,9 +945,15 @@ end; { TIBStringField} -constructor TIBStringField.create(AOwner: TComponent); +function TIBStringField.GetDefaultWidth: Longint; begin - inherited Create(AOwner); + Result := Size div CharacterSetSize; +end; + +constructor TIBStringField.Create(aOwner: TComponent); +begin + inherited Create(aOwner); + FCharacterSetSize := 1; end; class procedure TIBStringField.CheckTypeSize(Value: Integer); @@ -841,22 +1008,6 @@ begin end; end; -procedure TIBStringField.SetSize(AValue: Integer); -var FieldSize: integer; -begin - if csLoading in ComponentState then - FInitialised := true; - if FInitialised then - inherited SetSize(AValue) - else - begin - {IBCustomDataSet encodes the CharWidth size in the size} - FieldSize := AValue div 4; - inherited SetSize(FieldSize); - DisplayWidth := FieldSize div ((AValue mod 4) + 1); - FInitialised := true; - end; -end; { TIBBCDField } @@ -974,6 +1125,7 @@ begin FQRefresh.GoToFirstRecordOnExecute := False; FQSelect := TIBSQL.Create(Self); FQSelect.OnSQLChanging := SQLChanging; + FQSelect.OnSQLChanged := SQLChanged; FQSelect.GoToFirstRecordOnExecute := False; FQModify := TIBSQL.Create(Self); FQModify.OnSQLChanging := SQLChanging; @@ -2057,7 +2209,14 @@ begin FBase.CheckDatabase; FBase.CheckTransaction; if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then - FQSelect.SQL.Text := FParser.SQLText; + begin + FQSelect.OnSQLChanged := nil; {Do not react to change} + try + FQSelect.SQL.Text := FParser.SQLText; + finally + FQSelect.OnSQLChanged := SQLChanged; + end; + end; // writeln( FQSelect.SQL.Text); if FQSelect.SQL.Text <> '' then begin @@ -2304,7 +2463,6 @@ begin begin Disconnect; FQSelect.SQL.Assign(Value); - FBaseSQLSelect.assign(Value); end; end; @@ -2383,6 +2541,11 @@ begin FieldDefs.Updated := false; end; +procedure TIBCustomDataSet.SQLChanged(Sender: TObject); +begin + FBaseSQLSelect.assign(FQSelect.SQL); +end; + { I can "undelete" uninserted records (make them "inserted" again). I can "undelete" cached deleted (the deletion hasn't yet occurred) } procedure TIBCustomDataSet.Undelete; @@ -3078,6 +3241,7 @@ begin FreeMem(FOldBufferCache); FOldBufferCache := nil; BindFields(False); + ResetParser; if DefaultFields then DestroyFields; end; @@ -3151,7 +3315,9 @@ const var FieldType: TFieldType; FieldSize: Word; + charSetID: short; CharSetSize: integer; + CharSetName: string; FieldNullable : Boolean; i, FieldPosition, FieldPrecision: Integer; FieldAliasName, DBAliasName: string; @@ -3282,15 +3448,21 @@ begin FieldSize := 0; FieldPrecision := 0; FieldNullable := SourceQuery.Current[i].IsNullable; + CharSetSize := 0; + CharSetName := ''; case sqltype and not 1 of { All VARCHAR's must be converted to strings before recording their values } SQL_VARYING, SQL_TEXT: begin CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF); + CharSetName := FBase.GetCharSetName(sqlsubtype and $FF); {FieldSize is encoded for strings - see TIBStringField.SetSize for decode} - FieldSize := sqllen * 4 + (CharSetSize - 1); - FieldType := ftString; + FieldSize := sqllen; + if CharSetSize = 2 then + FieldType := ftWideString + else + FieldType := ftString; end; { All Doubles/Floats should be cast to doubles } SQL_DOUBLE, SQL_FLOAT: @@ -3349,7 +3521,24 @@ begin begin FieldSize := sizeof (TISC_QUAD); if (sqlsubtype = 1) then - FieldType := ftmemo + begin + if strpas(sqlname) = '' then {Complex SQL with no identifiable column - use connection default} + begin + CharSetSize := FBase.GetDefaultCharSetSize; + CharSetName := FBase.GetDefaultCharSetName; + end + else + begin + charSetID := GetBlobCharSetID(Database.Handle,Database.InternalTransaction.Handle, + @relname,@sqlname); + CharSetSize := FBase.GetCharSetSize(charSetID); + CharSetName := FBase.GetCharSetName(charSetID); + end; + if CharSetSize = 2 then + FieldType := ftWideMemo + else + FieldType := ftMemo; + end else FieldType := ftBlob; end; @@ -3368,15 +3557,16 @@ begin begin FMappedFieldPosition[FieldIndex] := FieldPosition; Inc(FieldIndex); - with FieldDefs.AddFieldDef do + with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do begin Name := FieldAliasName; FAliasNameMap[FieldNo-1] := DBAliasName; - DataType := FieldType; Size := FieldSize; Precision := FieldPrecision; Required := not FieldNullable; InternalCalcField := False; + CharacterSetSize := CharSetSize; + CharacterSetName := CharSetName; if (FieldName <> '') and (RelationName <> '') then begin if Has_COMPUTED_BLR(RelationName, FieldName) then @@ -3517,6 +3707,71 @@ procedure TIBCustomDataSet.InternalOpen; result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData)); end; + function GetFieldDef(aFieldNo: integer): TIBFieldDef; + var i: integer; + begin + Result := nil; + for i := 0 to FieldDefs.Count - 1 do + if FieldDefs[i].FieldNo = aFieldNo then + begin + Result := TIBFieldDef(FieldDefs[i]); + break; + end; + end; + + procedure SetExtendedProperties; + var i: integer; + IBFieldDef: TIBFieldDef; + begin + for i := 0 to Fields.Count - 1 do + if Fields[i].FieldNo > 0 then + begin + if(Fields[i] is TIBStringField) then + with TIBStringField(Fields[i]) do + begin + IBFieldDef := GetFieldDef(FieldNo); + if IBFieldDef <> nil then + begin + CharacterSetSize := IBFieldDef.CharacterSetSize; + CharacterSetName := IBFieldDef.CharacterSetName; + end; + end + else + if(Fields[i] is TIBWideStringField) then + with TIBWideStringField(Fields[i]) do + begin + IBFieldDef := GetFieldDef(FieldNo); + if IBFieldDef <> nil then + begin + CharacterSetSize := IBFieldDef.CharacterSetSize; + CharacterSetName := IBFieldDef.CharacterSetName; + end; + end + else + if(Fields[i] is TIBMemoField) then + with TIBMemoField(Fields[i]) do + begin + IBFieldDef := GetFieldDef(FieldNo); + if IBFieldDef <> nil then + begin + CharacterSetSize := IBFieldDef.CharacterSetSize; + CharacterSetName := IBFieldDef.CharacterSetName; + end; + end + else + if(Fields[i] is TIBWideMemoField) then + with TIBWideMemoField(Fields[i]) do + begin + IBFieldDef := GetFieldDef(FieldNo); + if IBFieldDef <> nil then + begin + CharacterSetSize := IBFieldDef.CharacterSetSize; + CharacterSetName := IBFieldDef.CharacterSetName; + end; + end + end + end; + begin FBase.SetCursor; try @@ -3531,6 +3786,7 @@ begin if DefaultFields then CreateFields; BindFields(True); + SetExtendedProperties; FCurrentRecord := -1; FQSelect.ExecQuery; FOpen := FQSelect.Open; @@ -3931,7 +4187,12 @@ begin begin FParser.Free; FParser := nil; - SQLChanging(nil) + FQSelect.OnSQLChanged := nil; {Do not react to change} + try + FQSelect.SQL.Assign(FBaseSQLSelect); + finally + FQSelect.OnSQLChanged := SQLChanged; + end; end; end; @@ -4364,4 +4625,5 @@ begin Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction); end; + end.