Commits

Anonymous committed bfe89b4

Minor fixes + added TASStringArrayProvider

  • Participants
  • Parent commits f9853f0

Comments (0)

Files changed (6)

Demo/TestMain.dfm

   Left = 0
   Top = 0
   Caption = 'AS Provider Demo App'
-  ClientHeight = 511
-  ClientWidth = 698
+  ClientHeight = 593
+  ClientWidth = 967
   Color = clBtnFace
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
   Font.Name = 'Tahoma'
   Font.Style = []
   OldCreateOrder = False
-  DesignSize = (
-    698
-    511)
   PixelsPerInch = 96
   TextHeight = 13
   object DBText1: TDBText
   object DBGrid1: TDBGrid
     Left = 0
     Top = 0
-    Width = 698
+    Width = 967
     Height = 137
     Align = alTop
     DataSource = DataSource1
   end
   object DBGrid2: TDBGrid
     Left = 0
-    Top = 390
-    Width = 698
-    Height = 121
+    Top = 376
+    Width = 967
+    Height = 217
     Align = alBottom
+    Anchors = [akLeft, akTop, akRight, akBottom]
     DataSource = DataSource2
     TabOrder = 4
     TitleFont.Charset = DEFAULT_CHARSET
   end
   object DBNavigator2: TDBNavigator
     Left = 8
-    Top = 359
+    Top = 345
     Width = 240
     Height = 25
     DataSource = DataSource2
-    Anchors = [akLeft, akBottom]
     TabOrder = 5
   end
   object DBEdit1: TDBEdit
     Top = 176
   end
   object DataSource2: TDataSource
-    DataSet = ClientDataSet1
+    DataSet = DS
     OnDataChange = DataSource2DataChange
     OnUpdateData = DataSource2UpdateData
-    Left = 160
-    Top = 224
+    Left = 136
+    Top = 280
   end
   object ActionList1: TActionList
     Left = 56
       OnUpdate = Action4Update
     end
   end
+  object DS: TClientDataSet
+    Aggregates = <>
+    FieldDefs = <
+      item
+        Name = 'TMySet'
+        ChildDefs = <
+          item
+            Name = 'TMySetFieldKey'
+            DataType = ftString
+            Size = 20
+          end
+          item
+            Name = 'TMySetFieldValue'
+            DataType = ftString
+            Size = 20
+          end>
+        DataType = ftArray
+        Size = 10
+      end>
+    IndexDefs = <>
+    Params = <>
+    StoreDefs = True
+    Left = 248
+    Top = 280
+  end
 end

Demo/TestMain.pas

     Button4: TButton;
     Action3: TAction;
     Action4: TAction;
+    DS: TClientDataSet;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure DataSource2DataChange(Sender: TObject; Field: TField);

Src/ASProvider.pas

 interface
 
 uses
-  SysUtils, Classes, DB, DBClient, Provider;
+  SysUtils, Classes, DB, DBClient, Provider, Rtti, TypInfo;
 
 type
   TASCustomProvider = class(TBaseProvider)
     procedure ExtractMetaData; virtual; abstract;
     procedure ExtractData; virtual; abstract;
 
-    procedure ApplyUpdate(Index: Integer; const FieldName: string; const Value: Variant); virtual; abstract;
-    procedure ApplyInsert(var Index: Integer); virtual; abstract;
-    procedure ApplyDelete(Index: Integer); virtual; abstract;
+    procedure ApplyUpdate(Index: Integer; const FieldName: string; const Value: Variant); virtual;
+    procedure ApplyInsert(var Index: Integer); virtual;
+    procedure ApplyDelete(Index: Integer); virtual;
+
+    class function RttiTypeToFieldType(T: PTypeInfo): TFieldType; virtual;
 
     procedure InitializeDataset; virtual;
     property DataSet: TPacketDataSet read GetDataSet;
     property DSWriter: TDataPacketWriter read GetDSWriter;
 
   public
-//    constructor Create; overload;
-    constructor Create(AOwner: TComponent); {overload;} override;
+    constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
 
     procedure Open;
     procedure Close;
+    procedure Refresh;
 
     property Active: Boolean read FActive write SetActive;
     property FieldDefs: TFieldDefs read GetFieldDefs write SetFieldDefs;
   published
     property Active;
     property FieldDefs;
-    property ProvidedObject;
     property Options;
   end;
 
     property ProvidedCollection: TCollection read GetProvidedTypedObject write SetProvidedTypedObject;
   end;
 
+  TASCustomArrayProvider<T> = class(TASCustomProvider)
+  private
+    FArray: TArray<T>;
+    FArrayName: string;
+    procedure SetArray(const Value: TArray<T>);
+    function IsArrayNameStored: Boolean;
+    procedure SetArrayName(const Value: string);
+
+  protected
+    procedure ExtractMetaData; override;
+    procedure ExtractData; override;
+
+    procedure ApplyUpdate(Index: Integer; const FieldName: string; const Value: Variant); override;
+    procedure ApplyInsert(var Index: Integer); override;
+    procedure ApplyDelete(Index: Integer); override;
+  public
+    property ProvidedArray: TArray<T> read FArray write SetArray;
+    property ArrayName: string read FArrayName write SetArrayName stored IsArrayNameStored;
+  end;
+
+  TASStringArrayProvider = class(TASCustomArrayProvider<string>)
+  published
+    property ArrayName;
+    property Active;
+    property FieldDefs;
+    property Options;
+  end;
+
   TASResolver = class(TCustomResolver)
   protected
     function GetDeltaIndex(Tree: TUpdateTree): Integer; virtual;
 implementation
 
 uses
-  Rtti, TypInfo, Variants, Forms;
+  Variants, Forms, StrUtils;
 
 procedure Register;
 begin
-  RegisterComponents('ASTEKK', [TASProvider, TASComponentProvider, TASCollectionProvider]);
+  RegisterComponents('ASTEKK', [TASProvider, TASComponentProvider, TASCollectionProvider, TASStringArrayProvider]);
+end;
+
+function GetLookupDataSetName(const TypeName: ShortString): string;
+begin
+  Result := 'AS_' + ReplaceStr(string(TypeName), '.', '_') + '_DataSet';
+end;
+
+function GetLookupProviderName(const TypeName: ShortString): string;
+begin
+  Result := 'AS_' + ReplaceStr(string(TypeName), '.', '_') + '_Provider';
 end;
 
 { TASCustomProvider }
 
+procedure TASCustomProvider.ApplyDelete(Index: Integer);
+begin
+  DatabaseError('Delete not supported', Self);
+end;
+
+procedure TASCustomProvider.ApplyInsert(var Index: Integer);
+begin
+  DatabaseError('Insert not supported', Self);
+end;
+
+procedure TASCustomProvider.ApplyUpdate(Index: Integer; const FieldName: string; const Value: Variant);
+begin
+  DatabaseError('Update not supported', Self);
+end;
+
 procedure TASCustomProvider.Close;
 begin
   Active := False;
   Options := [poDisableInserts, poDisableDeletes, poUseQuoteChar];
 end;
 
-{constructor TASCustomProvider.Create;
-begin
-  Create(nil);
-end;}
-
 procedure TASCustomProvider.CreateDataPacket(PacketOpts: TGetRecordOptions; ProvOpts: TProviderOptions;
   var RecsOut: Integer; var Data: OleVariant);
 begin
   Active := True;
 end;
 
+procedure TASCustomProvider.Refresh;
+begin
+  ExtractData;
+end;
+
+class function TASCustomProvider.RttiTypeToFieldType(T: PTypeInfo): TFieldType;
+const
+  type_map: array[TTypeKind] of TFieldType = (
+    ftUnknown,          //    tkUnknown
+    ftInteger,          //    tkInteger
+    ftFixedChar,        //    tkChar
+    ftInteger,          //    tkEnumeration
+    ftFloat,            //    tkFloat
+    ftString,           //    tkString
+    ftUnknown,          //    tkSet
+    ftUnknown,          //    tkClass
+    ftUnknown,          //    tkMethod
+    ftFixedWideChar,    //    tkWChar
+    ftString,           //    tkLString
+    ftWideString,       //    tkWString
+    ftVariant,          //    tkVariant
+    ftUnknown,          //    tkArray
+    ftUnknown,          //    tkRecord
+    ftUnknown,          //    tkInterface
+    ftUnknown,          //    tkInt64
+    ftUnknown,          //    tkDynArray
+    ftWideString,       //    tkUString
+    ftUnknown,          //    tkClassRef
+    ftUnknown,          //    tkPointer
+    ftUnknown           //    tkProcedure
+  );
+
+  {
+  Available field types:
+    ftString, ftSmallint, ftInteger, ftWord, // 0..4
+    ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, // 5..11
+    ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, // 12..18
+    ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString, // 19..24
+    ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, // 25..31
+    ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, // 32..37
+    ftFixedWideChar, ftWideMemo, ftOraTimeStamp, ftOraInterval, // 38..41
+    ftLongWord, ftShortint, ftByte, ftExtended, ftConnection, ftParams, ftStream, //42..48
+    ftTimeStampOffset, ftObject, ftSingle
+  }
+
+begin
+  if T^.Name = 'Boolean' then
+    Result := ftBoolean
+  else
+    Result := type_map[T^.Kind];
+end;
+
 procedure TASCustomProvider.SetActive(const Value: Boolean);
 begin
   if csReading in ComponentState then
       if FieldDefs.Count = 0 then
         ExtractMetaData;
       ExtractData;
+      DataSet.First;
     end;
 
     FActive := Value;
     if F.ReadOnly then
       Continue;
 
+    if VarIsClear(F.NewValue) then
+      Continue;
+
     if F.NewValue = F.OldValue then
       Continue;
 
   T: TRttiType;
   P: TRttiProperty;
   F: TFieldType;
-
-  function RttiTypeToFieldType(T: TRttiType): TFieldType;
-  const
-    type_map: array[TTypeKind] of TFieldType = (
-      ftUnknown,          //    tkUnknown
-      ftInteger,          //    tkInteger
-      ftFixedChar,        //    tkChar
-      ftUnknown,          //    tkEnumeration
-      ftFloat,            //    tkFloat
-      ftString,           //    tkString
-      ftUnknown,          //    tkSet
-      ftUnknown,          //    tkClass
-      ftUnknown,          //    tkMethod
-      ftFixedWideChar,    //    tkWChar
-      ftString,           //    tkLString
-      ftWideString,       //    tkWString
-      ftVariant,          //    tkVariant
-      ftArray,            //    tkArray
-      ftUnknown,          //    tkRecord
-      ftUnknown,          //    tkInterface
-      ftUnknown,          //    tkInt64
-      ftUnknown,          //    tkDynArray
-      ftWideString,       //    tkUString
-      ftUnknown,          //    tkClassRef
-      ftUnknown,          //    tkPointer
-      ftUnknown           //    tkProcedure
-    );
-
-    {
-    Available field types:
-      ftString, ftSmallint, ftInteger, ftWord, // 0..4
-      ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, // 5..11
-      ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, // 12..18
-      ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString, // 19..24
-      ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, // 25..31
-      ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, // 32..37
-      ftFixedWideChar, ftWideMemo, ftOraTimeStamp, ftOraInterval, // 38..41
-      ftLongWord, ftShortint, ftByte, ftExtended, ftConnection, ftParams, ftStream, //42..48
-      ftTimeStampOffset, ftObject, ftSingle
-    }
-
-  begin
-    Result := type_map[T.TypeKind];
-  end;
+  L: TStringField;
+  N: string;
 
 begin
   FieldDefs.Clear;
         if not ((P.Visibility in [mvPublic, mvPublished]) and P.IsReadable) then
           Continue;
 
-        F := RttiTypeToFieldType(P.PropertyType);
+        F := RttiTypeToFieldType(P.PropertyType.Handle);
         if F = ftUnknown then
           Continue;
 
 
   for I in ProvidedCollection do
     ExtractObjectData(I);
-
-  DataSet.First;
 end;
 
 function TASCollectionProvider.GetProvidedTypedObject: TCollection;
     Result := F.AsInteger;
 end;
 
+{ TASCustomArrayProvider<T> }
+
+procedure TASCustomArrayProvider<T>.ApplyDelete(Index: Integer);
+begin
+  inherited;
+end;
+
+procedure TASCustomArrayProvider<T>.ApplyInsert(var Index: Integer);
+begin
+  inherited;
+end;
+
+procedure TASCustomArrayProvider<T>.ApplyUpdate(Index: Integer; const FieldName: string; const Value: Variant);
+begin
+  inherited;
+end;
+
+procedure TASCustomArrayProvider<T>.ExtractData;
+var
+  I: T;
+  F: TField;
+  R: Boolean;
+
+begin
+  InitializeDataset;
+
+  if not Assigned(FArray) then
+    Exit;
+
+  for I in ProvidedArray do begin
+    DataSet.Append;
+    try
+      F := DataSet.Fields[0];
+      R := F.ReadOnly;
+      if R then
+        F.ReadOnly := False;
+
+      F.Value := TValue.From<T>(I).AsVariant;
+
+      if R then
+        F.ReadOnly := True;
+
+      DataSet.Post;
+    except
+      DataSet.Cancel;
+      raise;
+    end;
+  end;
+end;
+
+procedure TASCustomArrayProvider<T>.ExtractMetaData;
+var
+  Ctx: TRttiContext;
+  R: TRttiType;
+  F: TFieldType;
+
+begin
+  if FArrayName = '' then
+    FArrayName := Name;
+
+  FieldDefs.Clear;
+
+  Ctx := TRttiContext.Create;
+  try
+    R := Ctx.GetType(TypeInfo(T));
+    FieldDefs.BeginUpdate;
+    try
+      F := RttiTypeToFieldType(R.Handle);
+      Assert(F <> ftUnknown, ClassName + ': provider does not support type: ' + R.Name);
+
+      with FieldDefs.AddFieldDef do try
+        Name := ArrayName;
+        DataType := F;
+        if F = ftWideString then
+          Size := 20;
+
+        Attributes := [faReadonly];
+      except
+        Free;
+        raise;
+      end;
+    finally
+      FieldDefs.EndUpdate;
+    end;
+  finally
+    Ctx.Free;
+  end;
+end;
+
+function TASCustomArrayProvider<T>.IsArrayNameStored: Boolean;
+begin
+  Result := ArrayName <> Name;
+end;
+
+procedure TASCustomArrayProvider<T>.SetArray(const Value: TArray<T>);
+begin
+  FArray := Value;
+  ExtractData;
+end;
+
+procedure TASCustomArrayProvider<T>.SetArrayName(const Value: string);
+begin
+  if Value = ArrayName then
+    Exit;
+
+  FArrayName := Value;
+  ExtractMetaData;
+end;
+
 end.
 

Test/TestASProvider.pas

     Size: Integer;
     DataType: TFieldType;
     Attr: TFieldAttributes;
+    ChildDefs: array of TExpectFieldDef;
   end;
 
   TExpectItem = record
   strict private
     FProvider: TASCustomProvider;
   protected
-    procedure CheckFieldDef(Expect: TExpectFieldDef; const Msg: string = '');
+    procedure CheckFieldDef(FieldDefs: TFieldDefs; Expect: TExpectFieldDef; const Msg: string = '');
     procedure CheckMetaData(ExpectFields: array of TExpectFieldDef; const Msg: string = '');
     procedure CheckItem(Expect: TExpectItem; const Msg: string = '');
     procedure CheckCollection(ExpectItems: array of TExpectItem; const Msg: string = '');
     CheckItem(ExpectItems[I], Msg);
 end;
 
-procedure TTestASProviderTestCase.CheckFieldDef(Expect: TExpectFieldDef; const Msg: string);
+procedure TTestASProviderTestCase.CheckFieldDef(FieldDefs: TFieldDefs; Expect: TExpectFieldDef; const Msg: string);
 var
   S: string;
 begin
   S := Format('%sField #%d ''%s'' ', [IfThen(Length(Msg) > 0, Msg + ', ', ''), Expect.Idx, Expect.Name]);
-  with CustomProvider.FieldDefs[Expect.Idx] do begin
+  with FieldDefs[Expect.Idx] do begin
     CheckEqualsString(Expect.Name, Name, S + 'name');
     CheckEquals(Expect.Size, Size, S + 'size');
     Check(Expect.DataType = DataType,
         ]
       )
     );
+
+    CheckEquals(HasChildDefs, Length(Expect.ChildDefs) > 0, 'Has child defs');
   end;
 end;
 
   end;
 
   for I := Low(ExpectFields) to High(ExpectFields) do
-    CheckFieldDef(ExpectFields[I], Msg);
+    CheckFieldDef(CustomProvider.FieldDefs, ExpectFields[I], Msg);
 end;
 
 function TTestASProviderTestCase.GetProviderClass: TASCustomProviderClass;

Test/asobjproviderTests.dpr

 {$ENDIF}
 
 uses
+  ExceptionLog,
   Forms,
   TestFramework,
   GUITestRunner,

Test/asobjproviderTests.dproj

 		<PropertyGroup Condition="'$(Cfg_1)'!=''">
 			<DCC_DebugDCUs>true</DCC_DebugDCUs>
 			<DCC_MapFile>3</DCC_MapFile>
-			<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
+			<DCC_Define>DEBUG;EUREKALOG;EUREKALOG_VER6;$(DCC_Define)</DCC_Define>
 			<DCC_Optimize>false</DCC_Optimize>
 			<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
 		</PropertyGroup>
 <!-- EurekaLog First Line
 [Exception Log]
 EurekaLog Version=6025
-Activate=0
+Activate=1
 Activate Handle=1
 Save Log File=1
 Foreground Tab=0
 mtException_AntiFreeze0="The application seems to be frozen."
 Count mtInvalidEmailMsg=1
 mtInvalidEmailMsg0="Invalid email."
-TextsCollection=English
+TextsCollection=
 EurekaLog Last Line -->