ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
(Generate patch)

Comparing ibx/trunk/runtime/IBCustomDataSet.pas (file contents):
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC vs.
Revision 35 by tony, Tue Jan 26 14:38:47 2016 UTC

# Line 120 | Line 120 | type
120  
121    TIBStringField = class(TStringField)
122    private
123 <    FInitialised: boolean;
123 >    FCharacterSetName: string;
124 >    FCharacterSetSize: integer;
125    protected
126 <    procedure SetSize(AValue: Integer); override;
126 >    function GetDefaultWidth: Longint; override;
127    public
128 <    constructor create(AOwner: TComponent); override;
128 >    constructor Create(aOwner: TComponent); override;
129      class procedure CheckTypeSize(Value: Integer); override;
130      function GetAsString: string; override;
131      function GetAsVariant: Variant; override;
132      function GetValue(var Value: string): Boolean;
133      procedure SetAsString(const Value: string); override;
134 +    property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
135 +    property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
136 +  end;
137 +
138 +  { TIBWideStringField }
139 +
140 +  TIBWideStringField = class(TWideStringField)
141 +  private
142 +    FCharacterSetName: string;
143 +    FCharacterSetSize: integer;
144 +  public
145 +    property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
146 +    property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
147    end;
148  
149    { TIBBCDField }
# Line 152 | Line 166 | type
166      property Size default 8;
167    end;
168  
169 +  {TIBMemoField}
170 +  {Allows us to show truncated text in DBGrids and anything else that uses
171 +   DisplayText}
172 +
173 +   TIBMemoField = class(TMemoField)
174 +   private
175 +     FCharacterSetName: string;
176 +     FCharacterSetSize: integer;
177 +     FDisplayTextAsClassName: boolean;
178 +     function GetTruncatedText: string;
179 +   protected
180 +     function GetDefaultWidth: Longint; override;
181 +     procedure GetText(var AText: string; ADisplayText: Boolean); override;
182 +   public
183 +     constructor Create(AOwner: TComponent); override;
184 +     property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
185 +     property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
186 +  published
187 +     property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
188 +                                            write FDisplayTextAsClassName;
189 +   end;
190 +
191 +   { TIBWideMemoField }
192 +
193 +   TIBWideMemoField = class(TWideMemoField)
194 +   private
195 +     FCharacterSetName: string;
196 +     FCharacterSetSize: integer;
197 +     FDisplayTextAsClassName: boolean;
198 +     function GetTruncatedText: string;
199 +   protected
200 +     function GetDefaultWidth: Longint; override;
201 +     procedure GetText(var AText: string; ADisplayText: Boolean); override;
202 +   public
203 +     constructor Create(AOwner: TComponent); override;
204 +     property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
205 +     property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
206 +   published
207 +      property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
208 +                                             write FDisplayTextAsClassName;
209 +   end;
210 +
211    TIBDataLink = class(TDetailDataLink)
212    private
213      FDataSet: TIBCustomDataSet;
# Line 341 | Line 397 | type
397      procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
398      procedure SetUniDirectional(Value: Boolean);
399      procedure RefreshParams;
344    procedure SQLChanging(Sender: TObject); virtual;
400      function AdjustPosition(FCache: PChar; Offset: DWORD;
401                              Origin: Integer): DWORD;
402      procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
# Line 371 | Line 426 | type
426      procedure InternalRefreshRow; virtual;
427      procedure InternalSetParamsFromCursor; virtual;
428      procedure CheckNotUniDirectional;
429 +    procedure SQLChanging(Sender: TObject); virtual;
430 +    procedure SQLChanged(Sender: TObject); virtual;
431  
432   (*    { IProviderSupport }
433      procedure PSEndTransaction(Commit: Boolean); override;
# Line 502 | Line 559 | type
559      procedure RecordModified(Value: Boolean);
560      procedure RevertRecord;
561      procedure Undelete;
562 <    procedure ResetParser;
562 >    procedure ResetParser; virtual;
563      function HasParser: boolean;
564  
565      { TDataSet support methods }
# Line 690 | Line 747 | DefaultFieldClasses: array[TFieldType] o
747      TVarBytesField,     { ftVarBytes }
748      TAutoIncField,      { ftAutoInc }
749      TBlobField,         { ftBlob }
750 <    TMemoField,         { ftMemo }
750 >    TIBMemoField,       { ftMemo }
751      TGraphicField,      { ftGraphic }
752      TBlobField,         { ftFmtMemo }
753      TBlobField,         { ftParadoxOle }
# Line 698 | Line 755 | DefaultFieldClasses: array[TFieldType] o
755      TBlobField,         { ftTypedBinary }
756      nil,                { ftCursor }
757      TStringField,       { ftFixedChar }
758 <    TWideStringField,    { ftWideString }
758 >    TIBWideStringField,    { ftWideString }
759      TLargeIntField,     { ftLargeInt }
760      nil,          { ftADT }
761      nil,        { ftArray }
# Line 713 | Line 770 | DefaultFieldClasses: array[TFieldType] o
770      TDateTimeField,    {ftTimestamp}
771      TIBBCDField,       {ftFMTBcd}
772      nil,  {ftFixedWideChar}
773 <    TWideMemoField);   {ftWideMemo}
773 >    TIBWideMemoField);   {ftWideMemo}
774   (*
775      TADTField,          { ftADT }
776      TArrayField,        { ftArray }
# Line 730 | Line 787 | DefaultFieldClasses: array[TFieldType] o
787  
788   implementation
789  
790 < uses IBIntf, Variants, FmtBCD;
790 > uses IBIntf, Variants, FmtBCD, LCLProc, LazUTF8;
791  
792   const FILE_BEGIN = 0;
793        FILE_CURRENT = 1;
# Line 753 | Line 810 | type
810      NextRelation : TRelationNode;
811    end;
812  
813 +  {Extended Field Def for character set info}
814 +
815 +  { TIBFieldDef }
816 +
817 +  TIBFieldDef = class(TFieldDef)
818 +  private
819 +    FCharacterSetName: string;
820 +    FCharacterSetSize: integer;
821 +  published
822 +    property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
823 +    property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
824 +  end;
825 +
826 + { TIBWideMemoField }
827 +
828 + function TIBWideMemoField.GetTruncatedText: string;
829 + begin
830 +  Result := GetAsString;
831 +
832 +  if Result <> '' then
833 +    if DisplayWidth = 0 then
834 +      Result := TextToSingleLine(Result)
835 +    else
836 +    if Length(Result) > DisplayWidth then {Show truncation with elipses}
837 +      Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
838 + end;
839 +
840 + function TIBWideMemoField.GetDefaultWidth: Longint;
841 + begin
842 +  Result := 128;
843 + end;
844 +
845 + procedure TIBWideMemoField.GetText(var AText: string; ADisplayText: Boolean);
846 + begin
847 +  if ADisplayText then
848 +  begin
849 +    if not DisplayTextAsClassName then
850 +      AText := GetTruncatedText
851 +    else
852 +      inherited GetText(AText, ADisplayText);
853 +  end
854 +  else
855 +    AText := GetAsString;
856 + end;
857 +
858 + constructor TIBWideMemoField.Create(AOwner: TComponent);
859 + begin
860 +  inherited Create(AOwner);
861 +  BlobType := ftWideMemo;
862 + end;
863 +
864 + { TIBMemoField }
865 +
866 + function TIBMemoField.GetTruncatedText: string;
867 + begin
868 +   Result := GetAsString;
869 +
870 +   if Result <> '' then
871 +   begin
872 +       case CharacterSetSize of
873 +       1:
874 +         if DisplayWidth = 0 then
875 +           Result := TextToSingleLine(Result)
876 +         else
877 +         if Length(Result) > DisplayWidth then {Show truncation with elipses}
878 +           Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
879 +
880 +       {2: case 2 ignored. This should be handled by TIBWideMemo}
881 +
882 +       3, {Assume UNICODE_FSS is really UTF8}
883 +       4: {Include GB18030 - assuming UTF8 routine work for this codeset}
884 +         if DisplayWidth = 0 then
885 +           Result := ValidUTF8String(TextToSingleLine(Result))
886 +         else
887 +         if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
888 +           Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
889 +       end;
890 +   end
891 + end;
892 +
893 + function TIBMemoField.GetDefaultWidth: Longint;
894 + begin
895 +  Result := 128;
896 + end;
897 +
898 + procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
899 + begin
900 +  if ADisplayText then
901 +  begin
902 +    if not DisplayTextAsClassName then
903 +      AText := GetTruncatedText
904 +    else
905 +      inherited GetText(AText, ADisplayText);
906 +  end
907 +  else
908 +    AText := GetAsString;
909 + end;
910 +
911 + constructor TIBMemoField.Create(AOwner: TComponent);
912 + begin
913 +  inherited Create(AOwner);
914 +  BlobType := ftMemo;
915 + end;
916 +
917   { TIBControlLink }
918  
919   destructor TIBControlLink.Destroy;
# Line 784 | Line 945 | end;
945  
946   { TIBStringField}
947  
948 < constructor TIBStringField.create(AOwner: TComponent);
948 > function TIBStringField.GetDefaultWidth: Longint;
949   begin
950 <  inherited Create(AOwner);
950 >  Result := Size div CharacterSetSize;
951 > end;
952 >
953 > constructor TIBStringField.Create(aOwner: TComponent);
954 > begin
955 >  inherited Create(aOwner);
956 >  FCharacterSetSize := 1;
957   end;
958  
959   class procedure TIBStringField.CheckTypeSize(Value: Integer);
# Line 841 | Line 1008 | begin
1008    end;
1009   end;
1010  
844 procedure TIBStringField.SetSize(AValue: Integer);
845 var FieldSize: integer;
846 begin
847  if csLoading in ComponentState then
848    FInitialised := true;
849  if FInitialised then
850    inherited SetSize(AValue)
851  else
852  begin
853    {IBCustomDataSet encodes the CharWidth size in the size}
854    FieldSize := AValue div 4;
855    inherited SetSize(FieldSize);
856    DisplayWidth := FieldSize div ((AValue mod 4) + 1);
857    FInitialised := true;
858  end;
859 end;
1011  
1012   { TIBBCDField }
1013  
# Line 974 | Line 1125 | begin
1125    FQRefresh.GoToFirstRecordOnExecute := False;
1126    FQSelect := TIBSQL.Create(Self);
1127    FQSelect.OnSQLChanging := SQLChanging;
1128 +  FQSelect.OnSQLChanged := SQLChanged;
1129    FQSelect.GoToFirstRecordOnExecute := False;
1130    FQModify := TIBSQL.Create(Self);
1131    FQModify.OnSQLChanging := SQLChanging;
# Line 2057 | Line 2209 | begin
2209      FBase.CheckDatabase;
2210      FBase.CheckTransaction;
2211      if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2212 <      FQSelect.SQL.Text := FParser.SQLText;
2212 >    begin
2213 >      FQSelect.OnSQLChanged := nil; {Do not react to change}
2214 >      try
2215 >        FQSelect.SQL.Text := FParser.SQLText;
2216 >      finally
2217 >        FQSelect.OnSQLChanged := SQLChanged;
2218 >      end;
2219 >    end;
2220   //   writeln( FQSelect.SQL.Text);
2221      if FQSelect.SQL.Text <> '' then
2222      begin
# Line 2304 | Line 2463 | begin
2463    begin
2464      Disconnect;
2465      FQSelect.SQL.Assign(Value);
2307    FBaseSQLSelect.assign(Value);
2466    end;
2467   end;
2468  
# Line 2383 | Line 2541 | begin
2541    FieldDefs.Updated := false;
2542   end;
2543  
2544 + procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
2545 + begin
2546 +  FBaseSQLSelect.assign(FQSelect.SQL);
2547 + end;
2548 +
2549   { I can "undelete" uninserted records (make them "inserted" again).
2550    I can "undelete" cached deleted (the deletion hasn't yet occurred) }
2551   procedure TIBCustomDataSet.Undelete;
# Line 3078 | Line 3241 | begin
3241    FreeMem(FOldBufferCache);
3242    FOldBufferCache := nil;
3243    BindFields(False);
3244 +  ResetParser;
3245    if DefaultFields then DestroyFields;
3246   end;
3247  
# Line 3151 | Line 3315 | const
3315   var
3316    FieldType: TFieldType;
3317    FieldSize: Word;
3318 +  charSetID: short;
3319    CharSetSize: integer;
3320 +  CharSetName: string;
3321    FieldNullable : Boolean;
3322    i, FieldPosition, FieldPrecision: Integer;
3323    FieldAliasName, DBAliasName: string;
# Line 3282 | Line 3448 | begin
3448          FieldSize := 0;
3449          FieldPrecision := 0;
3450          FieldNullable := SourceQuery.Current[i].IsNullable;
3451 +        CharSetSize := 0;
3452 +        CharSetName := '';
3453          case sqltype and not 1 of
3454            { All VARCHAR's must be converted to strings before recording
3455             their values }
3456            SQL_VARYING, SQL_TEXT:
3457            begin
3458              CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF);
3459 +            CharSetName := FBase.GetCharSetName(sqlsubtype and $FF);
3460              {FieldSize is encoded for strings - see TIBStringField.SetSize for decode}
3461 <            FieldSize := sqllen * 4 + (CharSetSize - 1);
3462 <            FieldType := ftString;
3461 >            FieldSize := sqllen;
3462 >            if CharSetSize = 2 then
3463 >              FieldType := ftWideString
3464 >            else
3465 >              FieldType := ftString;
3466            end;
3467            { All Doubles/Floats should be cast to doubles }
3468            SQL_DOUBLE, SQL_FLOAT:
# Line 3349 | Line 3521 | begin
3521            begin
3522              FieldSize := sizeof (TISC_QUAD);
3523              if (sqlsubtype = 1) then
3524 <              FieldType := ftmemo
3524 >            begin
3525 >              if strpas(sqlname) = '' then {Complex SQL with no identifiable column - use connection default}
3526 >              begin
3527 >                CharSetSize := FBase.GetDefaultCharSetSize;
3528 >                CharSetName := FBase.GetDefaultCharSetName;
3529 >              end
3530 >              else
3531 >              begin
3532 >                charSetID := GetBlobCharSetID(Database.Handle,Database.InternalTransaction.Handle,
3533 >                        @relname,@sqlname);
3534 >                CharSetSize := FBase.GetCharSetSize(charSetID);
3535 >                CharSetName := FBase.GetCharSetName(charSetID);
3536 >              end;
3537 >              if CharSetSize = 2 then
3538 >                FieldType := ftWideMemo
3539 >              else
3540 >                FieldType := ftMemo;
3541 >            end
3542              else
3543                FieldType := ftBlob;
3544            end;
# Line 3368 | Line 3557 | begin
3557          begin
3558            FMappedFieldPosition[FieldIndex] := FieldPosition;
3559            Inc(FieldIndex);
3560 <          with FieldDefs.AddFieldDef do
3560 >          with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
3561            begin
3562              Name := FieldAliasName;
3563              FAliasNameMap[FieldNo-1] := DBAliasName;
3375            DataType := FieldType;
3564              Size := FieldSize;
3565              Precision := FieldPrecision;
3566              Required := not FieldNullable;
3567              InternalCalcField := False;
3568 +            CharacterSetSize := CharSetSize;
3569 +            CharacterSetName := CharSetName;
3570              if (FieldName <> '') and (RelationName <> '') then
3571              begin
3572                if Has_COMPUTED_BLR(RelationName, FieldName) then
# Line 3517 | Line 3707 | procedure TIBCustomDataSet.InternalOpen;
3707      result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3708    end;
3709  
3710 +  function GetFieldDef(aFieldNo: integer): TIBFieldDef;
3711 +  var i: integer;
3712 +  begin
3713 +    Result := nil;
3714 +    for i := 0 to FieldDefs.Count - 1 do
3715 +      if FieldDefs[i].FieldNo = aFieldNo then
3716 +      begin
3717 +        Result := TIBFieldDef(FieldDefs[i]);
3718 +        break;
3719 +      end;
3720 +  end;
3721 +
3722 +  procedure SetExtendedProperties;
3723 +  var i: integer;
3724 +      IBFieldDef: TIBFieldDef;
3725 +  begin
3726 +    for i := 0 to Fields.Count - 1 do
3727 +      if Fields[i].FieldNo > 0 then
3728 +      begin
3729 +        if(Fields[i] is TIBStringField) then
3730 +        with TIBStringField(Fields[i]) do
3731 +        begin
3732 +          IBFieldDef := GetFieldDef(FieldNo);
3733 +          if IBFieldDef <> nil then
3734 +          begin
3735 +            CharacterSetSize := IBFieldDef.CharacterSetSize;
3736 +            CharacterSetName := IBFieldDef.CharacterSetName;
3737 +          end;
3738 +        end
3739 +        else
3740 +        if(Fields[i] is TIBWideStringField) then
3741 +        with TIBWideStringField(Fields[i]) do
3742 +        begin
3743 +          IBFieldDef := GetFieldDef(FieldNo);
3744 +          if IBFieldDef <> nil then
3745 +          begin
3746 +            CharacterSetSize := IBFieldDef.CharacterSetSize;
3747 +            CharacterSetName := IBFieldDef.CharacterSetName;
3748 +          end;
3749 +        end
3750 +        else
3751 +        if(Fields[i] is TIBMemoField) then
3752 +        with TIBMemoField(Fields[i]) do
3753 +        begin
3754 +          IBFieldDef := GetFieldDef(FieldNo);
3755 +          if IBFieldDef <> nil then
3756 +          begin
3757 +            CharacterSetSize := IBFieldDef.CharacterSetSize;
3758 +            CharacterSetName := IBFieldDef.CharacterSetName;
3759 +          end;
3760 +        end
3761 +        else
3762 +        if(Fields[i] is TIBWideMemoField) then
3763 +        with TIBWideMemoField(Fields[i]) do
3764 +        begin
3765 +          IBFieldDef := GetFieldDef(FieldNo);
3766 +          if IBFieldDef <> nil then
3767 +          begin
3768 +            CharacterSetSize := IBFieldDef.CharacterSetSize;
3769 +            CharacterSetName := IBFieldDef.CharacterSetName;
3770 +          end;
3771 +        end
3772 +      end
3773 +  end;
3774 +
3775   begin
3776    FBase.SetCursor;
3777    try
# Line 3531 | Line 3786 | begin
3786        if DefaultFields then
3787          CreateFields;
3788        BindFields(True);
3789 +      SetExtendedProperties;
3790        FCurrentRecord := -1;
3791        FQSelect.ExecQuery;
3792        FOpen := FQSelect.Open;
# Line 3931 | Line 4187 | begin
4187    begin
4188      FParser.Free;
4189      FParser := nil;
4190 <    SQLChanging(nil)
4190 >    FQSelect.OnSQLChanged := nil; {Do not react to change}
4191 >    try
4192 >      FQSelect.SQL.Assign(FBaseSQLSelect);
4193 >    finally
4194 >      FQSelect.OnSQLChanged := SQLChanged;
4195 >    end;
4196    end;
4197   end;
4198  
# Line 4364 | Line 4625 | begin
4625      Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4626   end;
4627  
4628 +
4629   end.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines