Source

asprovider / Src / ASProvider.pas

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
unit ASProvider;

interface

uses
  SysUtils, Classes, DB, DBClient, Provider;

type
  TASCustomProvider = class(TBaseProvider)
  private
    FActive: Boolean;
    FStreamedActive: Boolean;
    FClass: TClass;
    FObject: TObject;
    FDataSet: TCustomClientDataSet;
    FDSWriter: TDataPacketWriter;
    FFieldDefs: TFieldDefs;

  private
    function GetDataSet: TCustomClientDataSet;
    function GetDSWriter: TDataPacketWriter;
    function GetFieldDefs: TFieldDefs;
    procedure SetFieldDefs(const Value: TFieldDefs);
    procedure SetActive(const Value: Boolean);

  protected
    procedure SetProvidedClass(const Value: TClass); virtual;
    function GetProvidedClass: TClass; virtual;
    procedure SetProvidedObject(const Value: TObject); virtual;
    function GetProvidedObject: TObject; virtual;

    function CreateResolver: TCustomResolver; override;
    procedure CreateDataPacket(PacketOpts: TGetRecordOptions;
      ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant); override;

  protected
    procedure Loaded; override;
    procedure ExtractMetaData;
    procedure ExtractData;

    function CreateDataSet: TCustomClientDataSet; virtual;
    property DataSet: TCustomClientDataSet read GetDataSet;
    property DSWriter: TDataPacketWriter read GetDSWriter;

  public
    constructor Create; overload;
    constructor Create(AOwner: TComponent); overload; override;
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    property Active: Boolean read FActive write SetActive;
    property ProvidedClass: TClass read GetProvidedClass write SetProvidedClass;
    property ProvidedObject: TObject read GetProvidedObject write SetProvidedObject;
    property FieldDefs: TFieldDefs read GetFieldDefs write SetFieldDefs;
  end;

  TASProvider = class(TASCustomProvider)
  end;

  TASGenericProvider<T: class> = class(TASCustomProvider)
  private
    FTypedObject: T;

  protected
    procedure SetProvidedClass(const Value: TClass); override;

    function GetProvidedTypedObject: T;
    procedure SetProvidedTypedObject(const Value: T);

    property ProvidedObject;

  public
    property ProvidedTypedObject: T read GetProvidedTypedObject write SetProvidedTypedObject;
  end;

  TASComponentProvider = class(TASGenericProvider<TComponent>)
  private
    function GetProvidedComponent: TComponent;
    procedure SetProvidedComponent(const Value: TComponent);

  protected
    property ProvidedTypedObject;

  published
    property Active;
    property ProvidedComponent: TComponent read GetProvidedComponent write SetProvidedComponent;
    property FieldDefs;
  end;

  TASResolver = class(TCustomResolver)
  protected
    procedure DoUpdate(Tree: TUpdateTree); override;
    procedure DoDelete(Tree: TUpdateTree); override;
    procedure DoInsert(Tree: TUpdateTree); override;
    procedure InitializeConflictBuffer(Tree: TUpdateTree); override;
  public
    procedure InitTreeData(Tree: TUpdateTree); override;
  end;

procedure Register;

implementation

uses
  Forms, Rtti, TypInfo, Variants, CodeSiteLogging, ASDebug;

procedure Register;
begin
  RegisterComponents('ASTEKK', [TASProvider, TASComponentProvider]);
end;

{ TASCustomProvider }

procedure TASCustomProvider.Close;
begin
  Active := False;
end;

constructor TASCustomProvider.Create(AOwner: TComponent);
begin
  inherited;
  FFieldDefs := DefaultFieldDefsClass.Create(DataSet);
end;

constructor TASCustomProvider.Create;
begin
  Create(Application);
end;

procedure TASCustomProvider.CreateDataPacket(PacketOpts: TGetRecordOptions; ProvOpts: TProviderOptions;
  var RecsOut: Integer; var Data: OleVariant);
begin
  with DSWriter do begin
    PacketOptions := PacketOpts;
    Options := ProvOpts;
    GetDataPacket(DataSet, RecsOut, Data);
  end;
end;

function TASCustomProvider.CreateDataSet: TCustomClientDataSet;
begin
  Result := TClientDataSet.Create(Self);
end;

function TASCustomProvider.CreateResolver: TCustomResolver;
begin
  Result := TASResolver.Create(Self);
end;

destructor TASCustomProvider.Destroy;
begin
  FreeAndNil(FDSWriter);
  FreeAndNil(FFieldDefs);
  FreeAndNil(FDataSet);

  inherited;
end;

procedure TASCustomProvider.ExtractData;
var
  Ctx: TRttiContext;
  T: TRttiType;
  P: TRttiProperty;
  F: TField;
  R: Boolean;

begin
  DataSet.Active := False;
  DataSet.FieldDefs := FieldDefs;
  DataSet.CreateDataSet;

  if not Assigned(FObject) then
    Exit;

  Ctx := TRttiContext.Create;
  try
    T := Ctx.GetType(ProvidedClass);
    DataSet.Insert;
    try
      for F in DataSet.Fields do begin
        P := T.GetProperty(F.FieldName);
        if Assigned(P) then begin
          R := F.ReadOnly;
          if R then
            F.ReadOnly := False;

          F.Value := P.GetValue(GetProvidedObject).AsVariant;

          if R then
            F.ReadOnly := True;
//          CodeSite.Send('Set value %s = %s', [F.FieldName, VarToStr(P.GetValue(ProvidedObject).AsVariant)]);
        end;
      end;

      DataSet.Post;
    except
      DataSet.Cancel;
      raise;
    end;
  finally
    Ctx.Free;
  end;
end;

procedure TASCustomProvider.ExtractMetaData;
var
  Ctx: TRttiContext;
  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;

  function fullName(T: TRttiObject): string;
  begin
    Result := '';

    if T is TRttiNamedObject then
      Result := (T as TRttiNamedObject).Name;

    if Assigned(T.Parent) then
      Result := fullName(T.Parent) + '.' + Result;
  end;

begin
  FieldDefs.Clear;

  if not Assigned(FClass) then
    Exit;

  Ctx := TRttiContext.Create;
  try
    T := Ctx.GetType(ProvidedClass);
    FieldDefs.BeginUpdate;
    try
      for P in T.GetProperties do begin
        if not ((P.Visibility in [mvPublic, mvPublished]) and P.IsReadable) then
          Continue;

        F := RttiTypeToFieldType(P.PropertyType);
        if F = ftUnknown then
          Continue;

        if FieldDefs.IndexOf(P.Name) >= 0 then
          Continue;

//        CodeSite.Send('Add field ''%s'' (%s) [%s] as %s', [P.Name, P.PropertyType.Name, fullName(P), GetEnumName(TypeInfo(TFieldType), Integer(F))]);
        with FieldDefs.AddFieldDef do try
          Name := P.Name;
          DataType := F;
          if F in [ftString, ftWideString] then
            Size := 20;

          if not P.IsWritable then
            Attributes := [faReadonly];
        except
          Free;
          raise;
        end;
      end;
    finally
      FieldDefs.EndUpdate;
    end;
  finally
    Ctx.Free;
  end;
end;

function TASCustomProvider.GetDataSet: TCustomClientDataSet;
begin
  if not Assigned(FDataSet) then
    FDataSet := CreateDataSet;

  Result := FDataSet;
end;

function TASCustomProvider.GetDSWriter: TDataPacketWriter;
begin
  if not Assigned(FDSWriter) then
    FDSWriter := TDataPacketWriter.Create;

  Result := FDSWriter;
end;

function TASCustomProvider.GetFieldDefs: TFieldDefs;
begin
  Result := FFieldDefs;
end;

function TASCustomProvider.GetProvidedClass: TClass;
begin
  Result := FClass;
end;

function TASCustomProvider.GetProvidedObject: TObject;
begin
  Result := FObject;
end;

procedure TASCustomProvider.Loaded;
begin
  inherited;
  try
    Active := FStreamedActive;
{$IFDEF DEBUG}
  except
    on E: Exception do ApplicationShowException(E);
{$ELSE}
  finally
{$ENDIF}
  end;
end;

procedure TASCustomProvider.Open;
begin
  Active := True;
end;

procedure TASCustomProvider.SetActive(const Value: Boolean);
begin
  if csReading in ComponentState then
    FStreamedActive := Value
  else if Active <> Value then begin
    if Value then begin
      ExtractMetaData;
      ExtractData;
    end;

    FActive := Value;
  end;
end;

procedure TASCustomProvider.SetFieldDefs(const Value: TFieldDefs);
begin
  FFieldDefs.Assign(Value);
end;

procedure TASCustomProvider.SetProvidedClass(const Value: TClass);
begin
  FClass := Value;

  if Active then
    ExtractMetaData;
end;

procedure TASCustomProvider.SetProvidedObject(const Value: TObject);
begin
  if not Assigned(FClass) and Assigned(Value) then
    ProvidedClass := Value.ClassType;

  if Assigned(Value) and not Value.InheritsFrom(ProvidedClass) then
    raise EArgumentException.CreateFmt(
      '%s can not provide %s. It does not inherit from %s.',
      [
        ClassName, Value.ClassName, ProvidedClass.ClassName
      ]
    );

  FObject := Value;

  if Active then
    ExtractData;
end;

{ TASResolver }

procedure TASResolver.DoDelete(Tree: TUpdateTree);
begin

end;

procedure TASResolver.DoInsert(Tree: TUpdateTree);
begin

end;

procedure TASResolver.DoUpdate(Tree: TUpdateTree);
begin

end;

procedure TASResolver.InitializeConflictBuffer(Tree: TUpdateTree);
begin

end;

procedure TASResolver.InitTreeData(Tree: TUpdateTree);
begin
  Tree.Source := (Provider as TASCustomProvider).DataSet;
end;

{ TASGenericProvider<T> }

function TASGenericProvider<T>.GetProvidedTypedObject: T;
begin
  Result := FTypedObject;
  CodeSite.Send('GetProvidedObject', Result);
  TASDebug.OutputDebugStringFmt('GetProvidedObject: %s', [TValue.From<T>(Result).ToString]);
end;

procedure TASGenericProvider<T>.SetProvidedClass(const Value: TClass);
begin
  TASDebug.OutputDebugStringFmt('SetProvidedClass: %s', [TValue.From<TClass>(Value).ToString]);
  if Assigned(Value) and not Value.InheritsFrom(T) then
    raise EArgumentException.CreateFmt(
      '%s can not provide a %s. It does not inherit from %s.',
      [
        ClassName, Value.ClassName, T.ClassName
      ]
    );

  inherited;
end;

procedure TASGenericProvider<T>.SetProvidedTypedObject(const Value: T);
begin
  CodeSite.Send('SetProvidedObject', Value);
  TASDebug.OutputDebugStringFmt('SetProvidedObject: %s', [TValue.From<T>(Value).ToString]);
  FTypedObject := Value;
  SetProvidedObject(Value);
end;

{ TASComponentProvider }

function TASComponentProvider.GetProvidedComponent: TComponent;
begin
  Result := GetProvidedTypedObject;
end;

procedure TASComponentProvider.SetProvidedComponent(const Value: TComponent);
begin
  SetProvidedTypedObject(Value);
end;

end.