Internet/IE编程

开发平台：

Delphi

Provider.pas：源码内容

out ErrorCount: Integer): OleVariant;
var
OwnerData: OleVariant;
begin
Result := ApplyUpdates(Delta, MaxErrors, ErrorCount, OwnerData);
end;
function TCustomProvider.ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant;
begin
DoBeforeApplyUpdates(OwnerData);
Result := InternalApplyUpdates(Delta, MaxErrors, ErrorCount);
DoAfterApplyUpdates(OwnerData);
end;
procedure TCustomProvider.DoAfterGetRecords(var OwnerData: OleVariant);
begin
if Assigned(FAfterGetRecords) then FAfterGetRecords(Self, OwnerData);
end;
procedure TCustomProvider.DoBeforeGetRecords(Count: Integer; Options: Integer;
const CommandText: WideString; var Params, OwnerData: OleVariant);
begin
if Assigned(FBeforeGetRecords) then FBeforeGetRecords(Self, OwnerData);
end;
function TCustomProvider.GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer): OleVariant;
var
Params, OwnerData: OleVariant;
begin
Result := GetRecords(Count, RecsOut, Options, '', Params, OwnerData);
end;
function TCustomProvider.GetRecords(Count: Integer; out RecsOut: Integer; Options: Integer;
const CommandText: WideString; var Params, OwnerData: OleVariant): OleVariant;
begin
DoBeforeGetRecords(Count, Options, CommandText, Params, OwnerData);
Result := InternalGetRecords(Count, RecsOut, TGetRecordOptions(Byte(Options)),
CommandText, Params);
DoAfterGetRecords(OwnerData);
Params := InternalGetParams([ptOutput, ptInputOutput]);
end;
procedure TCustomProvider.DoAfterRowRequest(var OwnerData: OleVariant);
begin
if Assigned(FAfterRowRequest) then FAfterRowRequest(Self, OwnerData);
end;
procedure TCustomProvider.DoBeforeRowRequest(var OwnerData: OleVariant);
begin
if Assigned(FBeforeRowRequest) then FBeforeRowRequest(Self, OwnerData);
end;
function TCustomProvider.RowRequest(const Row: OleVariant; RequestType: Integer;
var OwnerData: OleVariant): OleVariant;
begin
DoBeforeRowRequest(OwnerData);
Result := InternalRowRequest(Row, TFetchOptions(Byte(RequestType)));
DoAfterRowRequest(OwnerData);
end;
procedure TCustomProvider.DoAfterExecute(var OwnerData: OleVariant);
begin
if Assigned(FAfterExecute) then FAfterExecute(Self, OwnerData);
end;
procedure TCustomProvider.DoBeforeExecute(const CommandText: WideString; var Params,
OwnerData: OleVariant);
begin
if Assigned(FBeforeExecute) then FBeforeExecute(Self, OwnerData);
end;
procedure TCustomProvider.Execute(const CommandText: WideString;
var Params, OwnerData: OleVariant);
begin
DoBeforeExecute(CommandText, Params, OwnerData);
InternalExecute(CommandText, Params);
DoAfterExecute(OwnerData);
Params := InternalGetParams([ptOutput, ptInputOutput]);
end;
procedure TCustomProvider.DoAfterGetParams(var OwnerData: OleVariant);
begin
if Assigned(FAfterGetParams) then FAfterGetParams(Self, OwnerData);
end;
procedure TCustomProvider.DoBeforeGetParams(var OwnerData: OleVariant);
begin
if Assigned(FBeforeGetParams) then FBeforeGetParams(Self, OwnerData);
end;
function TCustomProvider.GetParams(var OwnerData: OleVariant): OleVariant;
begin
DoBeforeGetParams(OwnerData);
Result := InternalGetParams;
DoAfterGetParams(OwnerData);
end;
function TCustomProvider.InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant;
begin
Result := NULL;
end;
procedure TCustomProvider.InternalExecute(const CommandText: WideString; var Params: OleVariant);
begin
end;
function TCustomProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
Options: TGetRecordOptions; const CommandText: WideString;
var Params: OleVariant): OleVariant;
begin
Result := NULL;
end;
function TCustomProvider.InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant;
begin
Result := NULL;
end;
function TCustomProvider.DataRequest(Input: OleVariant): OleVariant;
begin
if Assigned(FOnDataRequest) then
Result := FOnDataRequest(Self, Input) else
Result := NULL;
end;
{ TBaseProvider }
constructor TBaseProvider.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FProviderOptions := [];
end;
destructor TBaseProvider.Destroy;
begin
FResolver.Free;
inherited Destroy;
end;
procedure TBaseProvider.LocateRecord(Source, Delta: TDataSet);
begin
end;
procedure TBaseProvider.UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean);
begin
end;
procedure TBaseProvider.FetchDetails(Source, Delta: TDataSet);
begin
end;
procedure TBaseProvider.CheckResolver;
begin
if not Assigned(FResolver) then
FResolver := CreateResolver;
end;
procedure TBaseProvider.FreeResolver;
begin
FResolver.Free;
FResolver := nil;
end;
function TBaseProvider.InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
out ErrorCount: Integer): OleVariant;
begin
if poReadOnly in Options then DatabaseError(SReadOnlyProvider);
CheckResolver;
Result := Resolver.ApplyUpdates(Delta, MaxErrors, ErrorCount);
end;
function TBaseProvider.InternalRowRequest(const Row: OleVariant; RequestType: TFetchOptions): OleVariant;
begin
CheckResolver;
Result := Resolver.RowRequest(Row, RequestType);
end;
function TBaseProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
Options: TGetRecordOptions; const CommandText: WideString;
var Params: OleVariant): OleVariant;
begin
if (Count = 0) then
Include(Options, grMetaData);
RecsOut := Count;
CreateDataPacket(Options, Self.Options, RecsOut, Result);
DoOnGetData(Result);
end;
procedure TBaseProvider.DoOnGetData(var Data: OleVariant);
begin
if Assigned(OnGetData) then
begin
if not Assigned(FDataDS) then
FDataDS := TPacketDataSet.Create(Self) else
FDataDS.StreamMetaData := False;
FDataDS.AppendData(Data, False);
OnGetData(Self, FDataDS);
if FDataDS.ChangeCount > 0 then
begin
FDataDS.MergeChangeLog;
Data := FDataDS.Data;
end;
FDataDS.EmptyDataSet;
end;
end;
procedure TBaseProvider.DoOnUpdateData(Delta: TPacketDataSet);
begin
if Assigned(FOnUpdateData) then
begin
Delta.LogChanges := False;
FOnUpdateData(Self, Delta);
end;
end;
function TBaseProvider.CreateResolver: TCustomResolver;
begin
Result := nil;
end;
procedure TBaseProvider.CreateDataPacket(PacketOpts: TGetRecordOptions;
ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant);
begin
RecsOut := 0;
Data := NULL;
end;
{ TDataSetProvider }
type
PSQLInfo = ^TSQLInfo;
TSQLInfo = record
IsSQLBased: Boolean;
QuoteChar: string;
QuotedTable: string;
QuotedTableDot: string;
Opened: Boolean;
HasObjects: Boolean;
end;
constructor TDataSetProvider.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FResolveToDataSet := False;
FUpdateMode := upWhereAll;
FDSWriter := nil;
FConstraints := True;
FRecordsSent := 0;
end;
destructor TDataSetProvider.Destroy;
begin
FDSWriter.Free;
if Assigned(FParams) then
FParams.Free;
inherited Destroy;
end;
procedure TDataSetProvider.LocateRecord(Source, Delta: TDataSet);
begin
FDataSetOpened := not Source.Active;
if FDataSetOpened then Source.Open;
if not FindRecord(Source, Delta, UpdateMode) then
DatabaseError(SRecordChanged);
end;
function TDataSetProvider.FindRecord(Source, Delta: TDataSet;
UpdateMode: TUpdateMode): Boolean;
procedure GetFieldList(DataSet: TDataSet; UpdateMode: TUpdateMode; List: TList);
var
i: Integer;
begin
for i := 0 to DataSet.FieldCount - 1 do
with DataSet.Fields[i] do
begin
if (DataType in [ftBytes, ftVarBytes]) or IsBlob or
(DataSet.Fields[i] is TObjectField) then continue;
case UpdateMode of
upWhereKeyOnly:
if pfInKey in ProviderFlags then List.Add(DataSet.Fields[i]);
upWhereAll:
if pfInWhere in ProviderFlags then List.Add(DataSet.Fields[i]);
upWhereChanged:
if (pfInKey in ProviderFlags) or (not VarIsClear(NewValue)) then
List.Add(DataSet.Fields[i]);
end;
end;
end;
var
i: Integer;
KeyValues: Variant;
Fields: string;
FieldList: TList;
IsDelta: LongBool;
begin
Result := False;
TPacketDataSet(Delta).DSBase.GetProp(dspropISDELTA, @IsDelta);
FieldList := TList.Create;
try
GetFieldList(Delta, UpdateMode, FieldList);
if FieldList.Count > 1 then
begin
KeyValues := VarArrayCreate([0, FieldList.Count - 1], varVariant);
Fields := '';
for i := 0 to FieldList.Count - 1 do
with TField(FieldList[i]) do
begin
if IsDelta then
KeyValues[i] := OldValue else
KeyValues[i] := Value;
if Fields <> '' then Fields := Fields + ';';
Fields := Fields + FieldName;
end;
Result := Source.Locate(Fields, KeyValues, []);
end
else if FieldList.Count = 1 then
begin
with TField(FieldList[0]) do
if IsDelta then
Result := Source.Locate(FieldName, OldValue, []) else
Result := Source.Locate(FieldName, Value, []);
end else
DatabaseError(SNoKeySpecified);
finally
FieldList.Free;
end;
end;
procedure TDataSetProvider.FetchDetails(Source, Delta: TDataSet);
var
i: Integer;
Field: TField;
begin
FDataSetOpened := not Source.Active;
if FDataSetOpened then Source.Open;
Source.First;
while not Source.EOF do
begin
Delta.Insert;
for i := 0 to Delta.FieldCount - 1 do
begin
Field := Source.FindField(Delta.Fields[i].FieldName);
if Field <> nil then
Delta.Fields[i].Assign(Field);
end;
Delta.Post;
Source.Next;
end;
end;
function TDataSetProvider.GetDataSetFromDelta(ATree: TUpdateTree; Source, Delta: TDataSet; Mode: TUpdateMode): TDataSet;
var
Alias: String;
FSQL: TStringList;
FParams: TParams;
begin
Result := nil;
FSQL := TStringList.Create;
FParams := TParams.Create;
try
CheckResolver;
if PSQLInfo(Resolver.FUpdateTree.Data)^.HasObjects then Alias := DefAlias else Alias := '';
TSQLResolver(Resolver).GenSelectSQL(ATree, FSQL, FParams, Alias, Mode);
IProviderSupport(Source).PSExecuteStatement(FSQL.Text, FParams, @Result);
if Result.EOF then
DatabaseError(SRecordChanged);
finally
FSQL.Free;
FParams.Free;
end;
end;
procedure TDataSetProvider.UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean);
var
Field: TField;
i: Integer;
UseUpMode: TUpdateMode;
DS: TDataSet;
begin
if KeyOnly then
UseUpMode := upWhereKeyOnly
else
UseUpMode := UpdateMode;
if Source.IsUnidirectional then
DS := TDataSetProvider(Self.Resolver.FProvider).GetDataSetFromDelta(
Self.Resolver.FUpdateTree, Source, Delta, UseUpMode)
else begin
if not FindRecord(Source, Delta, UseUpMode) then
DatabaseError(SRecordChanged);
DS := Source;
end;
with Delta do
begin
Edit;
for I := 0 to FieldCount - 1 do
begin
Field := DS.FindField(Fields[I].FieldName);
if (Field <> nil) and (not (Field.Lookup or Field.Calculated)) and
(not BlobsOnly or (Field.IsBlob and VarIsNull(Fields[i].NewValue))) then
Fields[i].Assign(Field);
end;
Post;
end;
if Source.IsUnidirectional then
DS.Free;
end;
procedure TDataSetProvider.DoBeforeExecute(const CommandText: WideString;
var Params, OwnerData: OleVariant);
begin
SetCommandText(CommandText);
SetParams(Params);
inherited DoBeforeExecute(CommandText, Params, OwnerData);
end;
procedure TDataSetProvider.InternalExecute(const CommandText: WideString;
var Params: OleVariant);
begin
CheckDataSet;
IProviderSupport(DataSet).PSExecute;
end;
procedure TDataSetProvider.DoGetTableName(DataSet: TDataSet; var TableName: string);
begin
if Assigned(OnGetTableName) then
OnGetTableName(Self, DataSet, TableName);
end;
procedure TDataSetProvider.Reset;
begin
CheckDataSet;
if FDataSetOpened then
begin
FDSWriter.Reset;
DataSet.Close;
FDataSetOpened := False;
end;
IProviderSupport(DataSet).PSReset;
if DataSet.Active then
DataSet.First;
FRecordsSent := 0;
end;
procedure TDataSetProvider.SetCommandText(const CommandText: string);
begin
if CommandText = '' then Exit;
if not (poAllowCommandText in Options) then
DatabaseError(SCannotChangeCommandText);
CheckDataSet;
IProviderSupport(DataSet).PSSetCommandText(CommandText);
end;
procedure TDataSetProvider.SetParams(Values: OleVariant);
begin
if VarIsClear(Values) then Exit;
CheckDataSet;
if not Assigned(FParams) then
FParams := TParams.Create;
FParams.Clear;
UnpackParams(Values, FParams);
IProviderSupport(DataSet).PSSetParams(FParams);
end;
function TDataSetProvider.InternalGetParams(Types: TParamTypes = AllParamTypes): OleVariant;
var
Params: TParams;
begin
CheckDataSet;
Params := IProviderSupport(DataSet).PSGetParams;
if (Params = nil) or (Params.Count = 0) then
Result := NULL else
Result := PackageParams(Params, Types);
end;
function TDataSetProvider.InternalRowRequest(const Row: OleVariant; Options: TFetchOptions): OleVariant;
begin
CheckResolver;
CheckDataSet;
Resolver.FUpdateTree.InitData(DataSet);
try
if not DataSet.Active then
begin
DataSet.Open;
FDataSetOpened := True;
end;
Result := inherited InternalRowRequest(Row, Options);
finally
Resolver.FUpdateTree.InitData(nil);
if FDataSetOpened then
begin
if Assigned(FDSWriter) then
FDSWriter.Reset;
DataSet.Close;
FDataSetOpened := False;
end;
end;
end;
function TDataSetProvider.InternalApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
out ErrorCount: Integer): OleVariant;
begin
CheckDataSet;
FTransactionStarted := not IProviderSupport(DataSet).PSInTransaction;
if FTransactionStarted and (GetObjectContext=nil) then
IProviderSupport(DataSet).PSStartTransaction;
try
CheckResolver;
Resolver.FUpdateTree.InitData(DataSet);
try
Result := inherited InternalApplyUpdates(Delta, MaxErrors, ErrorCount);
finally
Resolver.FUpdateTree.InitData(nil);
end;
finally
if FTransactionStarted and (GetObjectContext=nil) then
IProviderSupport(DataSet).PSEndTransaction((ErrorCount <= MaxErrors) or (MaxErrors = -1));
end;
end;
procedure TDataSetProvider.SetDataSet(ADataSet: TDataSet);
begin
FDataSet := ADataSet;
end;
procedure TDataSetProvider.SetResolveToDataSet(Value: Boolean);
begin
if (Value <> FResolveToDataSet) and Assigned(Resolver) then
FreeResolver;
FResolveToDataSet := Value;
end;
function TDataSetProvider.CreateResolver: TCustomResolver;
begin
if ResolveToDataSet then
Result := TDataSetResolver.Create(Self) else
Result := TSQLResolver.Create(Self);
end;
procedure TDataSetProvider.CheckDataSet;
begin
if not Assigned(DataSet) then DatabaseError(SMissingDataSet);
end;
procedure TDataSetProvider.DoBeforeGetRecords(Count: Integer; Options: Integer;
const CommandText: WideString; var Params, OwnerData: OleVariant);
begin
SetCommandText(CommandText);
SetParams(Params);
inherited DoBeforeGetRecords(Count, Options, CommandText, Params, OwnerData);
end;
function TDataSetProvider.InternalGetRecords(Count: Integer; out RecsOut: Integer;
Options: TGetRecordOptions; const CommandText: WideString;
var Params: OleVariant): OleVariant;
begin
try
if grReset in Options then
begin
Reset;
{ When doing only a reset and not getting more data then exit }
if Count = 0 then Exit;
end;
if not DataSet.Active then
begin
DataSet.Open;
FDataSetOpened := True;
end;
if (Count = 0) or (grMetaData in Options) then
begin
FDataDS.Free;
FDataDS := nil;
FRecordsSent := 0;
end;
DataSet.CheckBrowseMode;
DataSet.BlockReadSize := Count;
try
Result := inherited InternalGetRecords(Count, RecsOut, Options,
CommandText, Params);
Inc(FRecordsSent, RecsOut);
if (RecsOut <> Count) then Reset;
finally
if DataSet.Active then
begin
DataSet.BlockReadSize := 0;
if (Count <> 0) and (RecsOut = Count) then
DataSet.Next;
end;
end;
except
Reset;
raise;
end;
end;
procedure TDataSetProvider.DoGetProviderAttributes(DataSet: TDataSet; List: TList);
var
CustParams: OleVariant;
Attr: PPacketAttribute;
i, j: Integer;
begin
IProviderSupport(DataSet).PSGetAttributes(List);
if Assigned(FGetDSProps) then
begin
FGetDSProps(Self, DataSet, CustParams);
if VarIsArray(CustParams) then
begin
for i := VarArrayLowBound(CustParams, 1) to VarArrayHighBound(CustParams, 1) do
begin
if VarIsArray(CustParams[i]) and
(VarArrayHighBound(CustParams[i], 1) - VarArrayLowBound(CustParams[i], 1) = 2) then
begin
j := VarArrayLowBound(CustParams[i], 1);
New(Attr);
List.Add(Attr);
with Attr^ do
begin
Name := CustParams[i][j];
Value := CustParams[i][j + 1];
IncludeInDelta := CustParams[i][j + 2];
end;
end;
end;
end;
end;
end;
procedure TDataSetProvider.CreateDataPacket(PacketOpts: TGetRecordOptions;
ProvOpts: TProviderOptions; var RecsOut: Integer; var Data: OleVariant);
begin
if not Assigned(FDSWriter) then
FDSWriter := TDataPacketWriter.Create;
FDSWriter.Constraints := Constraints;
FDSWriter.OnGetParams := DoGetProviderAttributes;
FDSWriter.PacketOptions := PacketOpts;
FDSWriter.Options := ProvOpts;
FDSWriter.GetDataPacket(DataSet, RecsOut, Data);
end;
procedure TDataSetProvider.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataSet <> nil) and
(AComponent = FDataSet) then FDataSet := nil;
end;
{ TUpdateTree }
constructor TUpdateTree.Create(AParent: TUpdateTree; AResolver: TCustomResolver);
begin
FResolver := AResolver;
FParent := AParent;
FDeltaDS := TPacketDataSet.Create(nil);
FDeltaDS.ObjectView := True;
FDeltaDS.FieldDefs.HiddenFields := True;
FDetails := TList.Create;
FName := '';
end;
destructor TUpdateTree.Destroy;
begin
if Assigned(FResolver) then
FResolver.FreeTreeData(Self);
Clear;
FDetails.Free;
if not Assigned(Parent) then
FDeltaDS.Free;
inherited Destroy;
end;
function TUpdateTree.GetIsNested: Boolean;
begin
Result := Assigned(Source) and Assigned(Source.DataSetField);
end;
procedure TUpdateTree.Clear;
var
i: Integer;
begin
for i := 0 to DetailCount - 1 do
Details[i].Free;
FDetails.Clear;
FDeltaDS.Data := NULL;
if not Assigned(Parent) then
begin
FErrorDS.Free;
FErrorDS := nil;
end;
end;
function TUpdateTree.GetTree(const AName: string): TUpdateTree;
var
i: Integer;
begin
for i := 0 to DetailCount - 1 do
if AnsiCompareText(Details[i].Name, AName) = 0 then
begin
Result := Details[i];
Exit;
end;
Result := TUpdateTree.Create(Self, FResolver);
Result.Name := AName;
FDetails.Add(Result);
end;
procedure TUpdateTree.InitData(ASource: TDataSet);
var
i: Integer;
Tree: TUpdateTree;
List: TList;
begin
if ASource = nil then
begin
for i := 0 to FDetails.Count - 1 do
TUpdateTree(FDetails[i]).InitData(nil);
if FOpened then FSourceDS.Close;
FOpened := False;
end else
begin
FSourceDS := ASource;
FOpened := (FSourceDS.FieldCount = 0) and FSourceDS.ObjectView and
(not FSourceDS.IsUniDirectional);
if FOpened then FSourceDS.Open;
if FSourceDS.ObjectView then
for i := 0 to FSourceDS.FieldCount - 1 do
if FSourceDS.Fields[i].DataType in [ftDataSet] then
with TDataSetField(FSourceDS.Fields[i]) do
begin
Tree := GetTree(FSourceDS.Fields[i].FieldName);
Tree.InitData(NestedDataSet);
end;
List := TList.Create;
try
FSourceDS.GetDetailDataSets(List);
for i := 0 to List.Count - 1 do
begin
Tree := GetTree(TDataSet(List[i]).Name);
Tree.InitData(TDataSet(List[i]));
end;
finally
List.Free;
end;
end;
end;
type
TPropReader = class(TReader);
procedure TUpdateTree.InitDelta(ADelta: TPacketDataSet);
var
i: Integer;
Attr: Variant;
KeySet: Boolean;
Tree: TUpdateTree;
FieldInfo: TFieldInfo;
P: Pointer;
Stream: TMemoryStream;
Reader: TPropReader;
begin
if (FDeltaDS <> nil) and (FDeltaDS <> ADelta) then
FDeltaDS.Free;
FDeltaDS := ADelta;
FDeltaDS.LogChanges := False;
KeySet := False;
Stream := TMemoryStream.Create;
try
for i := 0 to FDeltaDS.FieldCount - 1 do
begin
Attr := FDeltaDS.InternalGetOptionalParam(szPROVFLAGS, FDeltaDS.Fields[i].FieldNo);
if not (VarIsNull(Attr) or VarIsClear(Attr)) then
FDeltaDS.Fields[i].ProviderFlags := TProviderFlags(Byte(Attr));
Attr := FDeltaDS.InternalGetOptionalParam(szORIGIN, FDeltaDS.Fields[i].FieldNo);
if not (VarIsNull(Attr) or VarIsClear(Attr)) then
FDeltaDS.Fields[i].Origin := Attr;
Attr := FDeltaDS.InternalGetOptionalParam(szSERVERCALC, FDeltaDS.Fields[i].FieldNo);
if not (VarIsClear(Attr) or VarIsNull(Attr)) and
(VarType(Attr) = varBoolean) and Boolean(Attr) then
FDeltaDS.Fields[i].Tag := tagSERVERCALC;
{Setup included field properties}
(**) Attr := FDeltaDS.InternalGetOptionalParam(szFIELDPROPS, FDeltaDS.Fields[i].FieldNo);
if not (VarIsNull(Attr) or VarIsClear(Attr) or not VarIsArray(Attr)) then
begin
Stream.Size := VarArrayHighBound(Attr, 1);
P := VarArrayLock(Attr);
try
Stream.Position := 0;
Stream.Write(Pointer(Integer(P))^, Stream.Size);
Stream.Position := 0;
finally
VarArrayUnlock(Attr);
end;
Attr := NULL;
Reader := TPropReader.Create(Stream, 1024);
try
Reader.ReadListBegin;
while not Reader.EndOfList do
Reader.ReadProperty(FDeltaDS.Fields[i]);
finally
Reader.Free;
end;
end;
if GetFieldInfo(FDeltaDS.Fields[i].Origin, FieldInfo) then
FDeltaDS.Fields[i].Origin := FieldInfo.OriginalFieldName else
FDeltaDS.Fields[i].Origin := FDeltaDS.Fields[i].FieldName;
if pfInKey in FDeltaDS.Fields[i].ProviderFlags then
KeySet := True;
if Delta.Fields[i].DataType = ftDataSet then
with TDataSetField(Delta.Fields[i]) do
begin
Tree := GetTree(Delta.Fields[i].FieldName);
Tree.InitDelta(TPacketDataSet(NestedDataSet));
end;
end;
finally
Stream.Free;
end;
FResolver.InitTreeData(Self);
if not KeySet then
FResolver.InitKeyFields(Self, FDeltaDS);
end;
procedure TUpdateTree.InitDelta(const ADelta: OleVariant);
begin
if FDeltaDS.Active then Clear;
FDeltaDS.Data := ADelta;
InitDelta(FDeltaDS);
end;
function TUpdateTree.GetDetailCount: Integer;
begin
Result := FDetails.Count;
end;
function TUpdateTree.GetDetail(Index: Integer): TUpdateTree;
begin
Result := TUpdateTree(FDetails[Index]);
end;
procedure TUpdateTree.RefreshData(Options: TFetchOptions);
function NeedsUpdate(DataSet: TDataSet): Boolean;
var
i: Integer;
Field: TField;
begin
Result := False;
if DataSet.RecordCount = 0 then Exit;
for i := 0 to DataSet.FieldCount - 1 do
begin
Field := DataSet.Fields[i];
Result := (Field is TDataSetField) and
(VarIsNull(Field.NewValue) or
NeedsUpdate(TDataSetField(Field).NestedDataSet));
if Result then Exit;
end;
end;
var
i: Integer;
Tree: TUpdateTree;
Field: TField;
Updated: Boolean;
begin
Updated := False;
if (foRecord in Options) and (Delta.RecordCount > 0) then
begin
Updated := True;
FResolver.Provider.UpdateRecord(Source, Delta, False, True);
end;
for i := 0 to Delta.FieldCount - 1 do
begin
Field := Delta.Fields[i];
if (not Updated) and (foBlobs in Options) and Field.IsBlob and
VarIsNull(Field.NewValue) then
begin
Updated := True;
FResolver.Provider.UpdateRecord(Source, Delta, True, False);
end;
if (Field is TDataSetField) then
begin
if not Updated then
FResolver.Provider.LocateRecord(Source, Delta);
Tree := GetTree(Field.FieldName);
if Assigned(Tree) then
begin
if not VarIsNull(Field.NewValue) then
begin
if Tree.Delta.RecordCount > 0 then
Tree.RefreshData(Options);
end else
FResolver.Provider.FetchDetails(Tree.Source, Tree.Delta);
end;
end;
end;
end;
function TUpdateTree.DoUpdates: Boolean;
var
i: Integer;
begin
Result := True;
Delta.First;
while not Delta.EOF do
begin
Delta.InitAltRecBuffers(False);
FResolver.InternalBeforeResolve(Self);
if (Delta.UpdateStatus = usInserted) then
begin
Result := FResolver.InternalUpdateRecord(Self);
if not Result then Exit;
end;
for i := 0 to DetailCount - 1 do
begin
Result := Details[i].DoUpdates;
if not Result then Exit;
end;
if Delta.UpdateStatus = usUnmodified then
Delta.InitAltRecBuffers(True);
if (Delta.UpdateStatus = usModified) then
Result := FResolver.InternalUpdateRecord(Self);
if (Delta.UpdateStatus = usDeleted) then
Result := FResolver.InternalUpdateRecord(Self);
if not Result then Exit;
Delta.Next;
end;
end;
function TUpdateTree.GetErrorDS: TPacketDataSet;
var
Field: TField;
begin
if not Assigned(FErrorDS) then
begin
if not Assigned(Parent) then
begin
FErrorDS := TPacketDataSet.Create(nil);
FErrorDS.ObjectView := True;
FErrorDS.CreateFromDelta(Delta);
end else
begin
Field := Parent.ErrorDS.FieldByName(Delta.DataSetField.FieldName);
FErrorDS := (Field as TDataSetField).NestedDataSet as TPacketDataSet;
end;
FErrorDS.LogChanges := False;
FErrorDS.DSBase.SetProp(DSProp(dspropAUTOINC_DISABLED), Integer(True));
end;
Result := FErrorDS;
end;
function TUpdateTree.GetHasErrors: Boolean;
begin
Result := Assigned(FErrorDS);
end;
procedure TUpdateTree.InitErrorPacket(E: EUpdateError; Response: TResolverResponse);
var
TrueRecNo: DWord;
begin
with ErrorDS do
begin
if Assigned(Parent) then Parent.InitErrorPacket(nil, rrSkip);
Self.Delta.UpdateCursorPos;
Self.Delta.DSCursor.GetRecordNumber(TrueRecNo);
if not Locate('ERROR_RECORDNO', Integer(TrueRecNo), []) then
Append else
Edit;
if not Assigned(E) then
begin
if Response = rrSkip then
begin
SetFields([TrueRecNo]);
Post;
end else
SetFields([TrueRecNo, 0, '', '', 0, 0]);
end else
SetFields([TrueRecNo, Ord(Response)+1, E.Message, '', 1, E.ErrorCode]);
end;
end;
{ TCustomResolver }
constructor TCustomResolver.Create(AProvider: TBaseProvider);
begin
FProvider := AProvider;
FUpdateTree := TUpdateTree.Create(nil, Self);
end;
destructor TCustomResolver.Destroy;
begin
FUpdateTree.Free;
inherited Destroy;
end;
{ Updates }
procedure TCustomResolver.BeginUpdate;
begin
end;
procedure TCustomResolver.EndUpdate;
begin
end;
procedure TCustomResolver.InitKeyFields(Tree: TUpdateTree; ADelta: TPacketDataSet);
var
Pos, i: Integer;
KeyFields, FieldName: string;
begin
KeyFields := IProviderSupport(Tree.Source).PSGetKeyFields;
Pos := 1;
while Pos <= Length(KeyFields) do
begin
FieldName := ExtractFieldName(KeyFields, Pos);
for i := 0 to ADelta.FieldCount - 1 do
if AnsiCompareText(FieldName, ADelta.Fields[i].Origin) = 0 then
begin
ADelta.Fields[i].ProviderFlags := ADelta.Fields[i].ProviderFlags + [pfInKey];
break;
end;
end;
end;
procedure TCustomResolver.InitTreeData(Tree: TUpdateTree);
begin
end;
procedure TCustomResolver.FreeTreeData(Tree: TUpdateTree);
begin
end;
procedure TCustomResolver.InternalBeforeResolve(Tree: TUpdateTree);
begin
end;
function TCustomResolver.InternalUpdateRecord(Tree: TUpdateTree): Boolean;
var
RecNoSave: Integer;
Applied: Boolean;
UpdateKind: TUpdateKind;
E: Exception;
PrevErr, Err: EUpdateError;
begin
PrevErr := nil;
Err := nil;
Tree.Delta.UseCurValues := False;
while True do
try
UpdateKind := Tree.Delta.UpdateKind;
if ((UpdateKind = ukInsert) and (FPrevResponse in [rrMerge, rrApply])) or
((FPrevResponse = rrMerge) and Tree.Delta.HasMergeConflicts) then
DatabaseError(SInvalidResponse);
Applied := False;
RecNoSave := Tree.Delta.RecNo;
try
if Assigned(Provider.BeforeUpdateRecord) then
Provider.BeforeUpdateRecord(Provider, Tree.Source, Tree.Delta, UpdateKind, Applied);
finally
if Tree.Delta.RecNo <> RecNoSave then
Tree.Delta.RecNo := RecNoSave;
end;
if not Applied then
case UpdateKind of
ukModify:
begin
if poDisableEdits in Provider.Options then
raise Exception.CreateRes(@SNoEditsAllowed);
DoUpdate(Tree);
end;
ukDelete:
begin
if poDisableDeletes in Provider.Options then
raise Exception.CreateRes(@SNoDeletesAllowed);
DoDelete(Tree);
end;
ukInsert:
begin
if poDisableInserts in Provider.Options then
raise Exception.CreateRes(@SNoInsertsAllowed);
DoInsert(Tree);
end;
end;
if Assigned(Provider.AfterUpdateRecord) then
Provider.AfterUpdateRecord(Provider, Tree.Source, Tree.Delta, UpdateKind);
if (poPropogateChanges in Provider.Options) and Tree.Delta.NewValuesModified then
LogUpdateRecord(Tree);
Break;
except
E := AcquireExceptionObject;
PrevErr.Free;
PrevErr := Err;
Err := IProviderSupport(Tree.Source).PSGetUpdateException(E, PrevErr);
if HandleUpdateError(Tree, Err, FMaxErrors, FErrorCount) then
begin
Tree.Delta.UseCurValues := True;
Continue;
end else
break;
end;
PrevErr.Free;
Err.Free;
FPrevResponse := rrSkip;
Result := FErrorCount <= FMaxErrors;
end;
function TCustomResolver.RowRequest(Row: OleVariant; Options: TFetchOptions): OleVariant;
begin
BeginUpdate;
try
FUpdateTree.InitDelta(Row);
try
FUpdateTree.RefreshData(Options);
Result := FUpdateTree.Delta.Data;
finally
FUpdateTree.Clear;
end;
finally
EndUpdate;
end;
end;
function TCustomResolver.ApplyUpdates(const Delta: OleVariant; MaxErrors: Integer;
out ErrorCount: Integer): OleVariant;
var
XmlMode: LongWord;
Status: Integer;
DataPacket: TDataPacket;
begin
BeginUpdate;
try
FUpdateTree.InitDelta(Delta);
try
Provider.DoOnUpdateData(FUpdateTree.Delta);
FPrevResponse := rrSkip;
if MaxErrors = -1 then MaxErrors := MaxInt;
FMaxErrors := MaxErrors;
FErrorCount := 0;
FUpdateTree.DoUpdates;
ErrorCount := FErrorCount;
if FUpdateTree.HasErrors then
begin
Status := FUpdateTree.ErrorDS.DSBase.GetProp(dspropXML_StreamMode, @XMLMode);
if (Status <> 0) or (XMLMode = 0) then
Result := FUpdateTree.ErrorDS.Data
else
begin
FUpdateTree.ErrorDS.Check(FUpdateTree.ErrorDS.DSBase.StreamDS(DataPacket));
DataPacketToVariant(DataPacket, Result);
end;
end else
Result := Null;
finally
FUpdateTree.Clear;
end;
finally
EndUpdate;
end;
end;
{ Update error handling }
function TCustomResolver.HandleUpdateError(Tree: TUpdateTree;
E: EUpdateError; var MaxErrors, ErrorCount: Integer): Boolean;
var
Response: TResolverResponse;
UpdateKind: TUpdateKind;
begin
UpdateKind := Tree.Delta.UpdateKind;
if ErrorCount < MaxErrors then
Response := rrSkip else
Response := rrAbort;
try
InitializeConflictBuffer(Tree);
except
{ Ignore errors that occur when initializing the conflict buffer }
end;
if Assigned(Provider.OnUpdateError) then
Provider.OnUpdateError(Provider, Tree.Delta, E, UpdateKind, Response);
if Response in [rrSkip, rrAbort] then
begin
Inc(ErrorCount);
if ErrorCount > MaxErrors then
Response := rrAbort;
if (Response = rrAbort) then
MaxErrors := ErrorCount - 1;
if Response in [rrSkip, rrAbort] then
LogUpdateError(Tree, E, Response);
end;
FPrevResponse := Response;
Result := Response in [rrMerge, rrApply];
end;
procedure TCustomResolver.LogUpdateRecord(Tree: TUpdateTree);
var
I: Integer;
CurVal: Variant;
begin
Tree.InitErrorPacket(nil, rrApply);
for I := 0 to Tree.Delta.FieldCount - 1 do
begin
{ Blobs, Bytes and VarBytes are not included in result packet }
if (Tree.Delta.Fields[I].IsBlob) or
(Tree.Delta.Fields[I].DataType in [ftBytes, ftVarBytes]) then
continue;
CurVal := Tree.Delta.Fields[I].NewValue;
if not VarIsClear(CurVal) then
Tree.ErrorDS.FieldByName(Tree.Delta.Fields[I].FieldName).Value := CurVal;
end;
Tree.ErrorDS.Post;
end;
procedure TCustomResolver.LogUpdateError(Tree: TUpdateTree;
E: EUpdateError; Response: TResolverResponse);
var
I: Integer;
CurVal: Variant;
begin
Tree.InitErrorPacket(E, Response);
if Tree.Delta.HasCurValues then
for I := 0 to Tree.Delta.FieldCount - 1 do
begin
{ Blobs, Bytes and VarBytes are not included in result packet }
if (Tree.Delta.Fields[I].IsBlob) or
(Tree.Delta.Fields[I].DataType in [ftBytes, ftVarBytes]) then
continue;
CurVal := Tree.Delta.Fields[I].CurValue;
if not VarIsClear(CurVal) then
Tree.ErrorDS.FieldByName(Tree.Delta.Fields[I].FieldName).Value := CurVal;
end;
Tree.ErrorDS.Post;
end;
{ TDataSetResolver }
constructor TDataSetResolver.Create(AProvider: TDataSetProvider);
begin
inherited Create(AProvider);
FOpened := False;
end;
function TDataSetResolver.GetProvider: TDataSetProvider;
begin
Result := TDataSetProvider(inherited Provider);
end;
procedure TDataSetResolver.BeginUpdate;
begin
FOpened := not Provider.DataSet.Active;
if FOpened then
begin
Provider.DataSet.Open;
FBookmark := '';
end else
FBookmark := Provider.DataSet.Bookmark;
end;
procedure TDataSetResolver.EndUpdate;
begin
if FOpened then
begin
Provider.DataSet.Close;
FOpened := False;
end else
begin
if (Length(FBookmark) > 0) and
Provider.DataSet.BookmarkValid(@FBookmark[1]) then
Provider.DataSet.Bookmark := FBookmark;
end;
end;
procedure TDataSetResolver.InitializeConflictBuffer(Tree: TUpdateTree);
begin
{ Set the conflict buffer to the current values of the data }
if Provider.FindRecord(Tree.Source, Tree.Delta, upWhereKeyOnly) then
Tree.Delta.AssignCurValues(Tree.Source);
end;
procedure TDataSetResolver.InternalBeforeResolve(Tree: TUpdateTree);
begin
Provider.FindRecord(Tree.Source, Tree.Delta, Provider.UpdateMode);
end;
procedure TDataSetResolver.PutRecord(Tree: TUpdateTree);
procedure PutField(Src, Dest: TField); forward;
procedure PutObjectField(Src, Dest: TObjectField);
var
i: Integer;
begin
if VarIsNull(Src.NewValue) then
Dest.Clear else
for i := 0 to Src.FieldCount - 1 do
if (not VarIsClear(Src.Fields[i].NewValue)) and
(pfInUpdate in Src.Fields[i].ProviderFlags) then
PutField(Src.Fields[i], Dest.Fields[i]);
end;
procedure PutField(Src, Dest: TField);
begin
if (Src.DataType in [ftArray, ftADT]) then
PutObjectField(TObjectField(Src), TObjectField(Dest)) else
if (Src.DataType in [ftDataSet, ftReference]) then
raise Exception.CreateRes(@SNoDataSets) else
if (not VarIsClear(Src.NewValue)) and
(pfInUpdate in Src.ProviderFlags) then
Dest.Assign(Src);
end;
var
i: Integer;
Field: TField;
begin
with Tree do
try
for i := 0 to Delta.FieldCount - 1 do
begin
Field := Source.FindField(Delta.Fields[i].FieldName);
if (Field <> nil) and (Delta.Fields[i].DataType <> ftDataSet) then
PutField(Delta.Fields[i], Field);
end;
Source.Post;
except
Source.Cancel;
raise;
end;
end;
procedure TDataSetResolver.DoUpdate(Tree: TUpdateTree);
begin
with Tree do
begin
if not Provider.FindRecord(Source, Delta, Provider.UpdateMode) then
DatabaseError(SRecordChanged);
Source.Edit;
PutRecord(Tree);
end;
end;
procedure TDataSetResolver.DoDelete(Tree: TUpdateTree);
begin
with Tree do
begin
if Provider.FindRecord(Tree.Source, Tree.Delta, Provider.UpdateMode) then
Source.Delete else
DatabaseError(SRecordChanged);
end;
end;
procedure TDataSetResolver.DoInsert(Tree: TUpdateTree);
begin
Tree.Source.Append;
PutRecord(Tree);
end;
{ TSQLResolver }
constructor TSQLResolver.Create(AProvider: TDataSetProvider);
begin
inherited Create(AProvider);
FSQL := TStringList.Create;
FParams := TParams.Create(nil);
end;
destructor TSQLResolver.Destroy;
begin
FSQL.Free;
FParams.Free;
inherited Destroy;
end;
function TSQLResolver.GetProvider: TDataSetProvider;
begin
Result := TDataSetProvider(inherited Provider);
end;
procedure TSQLResolver.InitTreeData(Tree: TUpdateTree);
function GetQuotedTableName(SQLBased: Boolean;
const QuoteChar, TableName: string): string;
var
DotPos, DotPos2: Integer;
begin
Result := '';
if Length(TableName) > 0 then
begin
if (TableName[1] in ['''','"','`']) or (TableName[strlen(PChar(TableName))] in ['''','"','`']) then
Result := TableName else
begin
if SQLBased then
begin
Result := TableName;
DotPos := Pos('.', Result);
DotPos2 := Pos('.',PChar(Result) + DotPos);
if DotPos2 <> 0 then
DotPos2 := DotPos2 + DotPos;
if (DotPos <> 0) and (DotPos2 <> 0 ) then
begin
System.Insert(QuoteChar, Result, DotPos2);
System.Insert(QuoteChar, Result, DotPos2 + 2);
System.Insert(QuoteChar, Result, DotPos + 1);
System.Insert(QuoteChar, Result, DotPos);
end
else
if DotPos <> 0 then
begin
System.Insert(QuoteChar, Result, DotPos + 1);
System.Insert(QuoteChar, Result, DotPos);
end;
Result := QuoteChar + Result + QuoteChar;
end else
Result := QuoteChar + TableName + QuoteChar;
end;
end;
end;
var
Info: PSQLInfo;
i: Integer;
TableName: string;
begin
if Tree.Data <> nil then
Dispose(PSQLInfo(Tree.Data));
New(Info);
Tree.Data := Info;
Info.IsSQLBased := IProviderSupport(Tree.Source).PSIsSQLBased;
Info.QuoteChar := IProviderSupport(Tree.Source).PSGetQuoteChar;
TableName := VarToStr(Tree.Delta.GetOptionalParam(szTABLE_NAME));
if TableName = '' then
TableName := IProviderSupport(Tree.Source).PSGetTableName;
Provider.DoGetTableName(Tree.Source, TableName);
if TableName <> '' then
Info.QuotedTable := GetQuotedTableName(Info.IsSQLBased, Info.QuoteChar, TableName);
if Info.IsSQLBased then
Info.QuotedTableDot := '' else
Info.QuotedTableDot := Info.QuotedTable + '.';
Info.HasObjects := False;
for i := 0 to Tree.Delta.FieldCount - 1 do
if (Tree.Delta.Fields[i] is TObjectField) and
(TObjectField(Tree.Delta.Fields[i]).ObjectType <> '') then
begin
Info.HasObjects := True;
break;
end;
end;
procedure TSQLResolver.FreeTreeData(Tree: TUpdateTree);
begin
Dispose(PSQLInfo(Tree.Data));
Tree.Data := nil;
end;
procedure TSQLResolver.DoExecSQL(SQL: TStringList; Params: TParams);
var
RowsAffected: Integer;
begin
RowsAffected := IProviderSupport(Provider.DataSet).PSExecuteStatement(SQL.Text, Params);
if not (poAllowMultiRecordUpdates in Provider.Options) and (RowsAffected > 1) then
begin
IProviderSupport(Provider.DataSet).PSEndTransaction(False);
Provider.FTransactionStarted := False;
DatabaseError(STooManyRecordsModified);
end;
if RowsAffected < 1 then
DatabaseError(SRecordChanged);
end;
procedure TSQLResolver.DoGetValues(SQL: TStringList; Params: TParams;
DataSet: TDataSet);
var
DS: TDataSet;
begin
DS := nil;
IProviderSupport(Provider.DataSet).PSExecuteStatement(SQL.Text, Params, @DS);
if Assigned(DS) then
try
TPacketDataSet(DataSet).AssignCurValues(DS)
finally
DS.Free;
end;
end;
procedure TSQLResolver.InitializeConflictBuffer(Tree: TUpdateTree);
var
Alias: string;
begin
if PSQLInfo(Tree.Data)^.HasObjects then Alias := DefAlias else Alias := '';
FSQL.Clear;
FParams.Clear;
GenSelectSQL(Tree, FSQL, FParams, Alias);
DoGetValues(FSQL, FParams, Tree.Delta);
end;
procedure TSQLResolver.InternalDoUpdate(Tree: TUpdateTree; UpdateKind: TUpdateKind);
var
Alias: string;
begin
if not IProviderSupport(Tree.Source).PSUpdateRecord(UpdateKind, Tree.Delta) then
begin
if (PSQLInfo(Tree.Data)^.QuotedTable = '') and not Tree.IsNested then
DatabaseError(SNoTableName);
if PSQLInfo(Tree.Data)^.HasObjects then Alias := DefAlias else Alias := '';
FSQL.Clear;
FParams.Clear;
case UpdateKind of
ukModify: GenUpdateSQL(Tree, FSQL, FParams, Alias);
ukInsert: GenInsertSQL(Tree, FSQL, FParams);
ukDelete: GenDeleteSQL(Tree, FSQL, FParams, Alias);
end;
DoExecSQL(FSQL, FParams);
end;
end;
procedure TSQLResolver.DoUpdate(Tree: TUpdateTree);
begin
InternalDoUpdate(Tree, ukModify);
end;
procedure TSQLResolver.DoDelete(Tree: TUpdateTree);
begin
InternalDoUpdate(Tree, ukDelete);
end;
procedure TSQLResolver.DoInsert(Tree: TUpdateTree);
begin
InternalDoUpdate(Tree, ukInsert);
end;
{ SQL generation }
function QuoteFullName(const FullName, QuoteChar: string): string;
var
i: Integer;
p: PChar;
begin
if (Length(FullName) > 1) and (FullName[1] in [#0, #1]) then
p := @FullName[2] else
p := PChar(FullName);
Result := Format('%s%s%0:s',[QuoteChar, p]);
for i := Length(Result) downto 1 do
if Result[i] = '.' then
begin
System.Insert(QuoteChar, Result, i + 1);
System.Insert(QuoteChar, Result, i);
end;
end;
function TSQLResolver.UseFieldInUpdate(Field: TField): Boolean;
const
ExcludedTypes = [ftAutoInc, ftDataSet, ftADT, ftArray, ftReference, ftCursor, ftUnknown];
begin
with Field do
begin
Result := (pfInUpdate in ProviderFlags) and not (DataType in ExcludedTypes) and
not ReadOnly and (FieldKind = fkData) and not (pfHidden in ProviderFlags) and
not VarIsClear(NewValue) and (Tag <> tagSERVERCALC);
end;
end;
function TSQLResolver.UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
const
ExcludedTypes = [ftDataSet, ftADT, ftArray, ftReference, ftCursor, ftUnknown];
begin
with Field do
begin
Result := not (DataType in ExcludedTypes) and not IsBlob and
(FieldKind = fkData) and (Tag <> tagSERVERCALC);
if Result then
case Mode of
upWhereAll:
Result := pfInWhere in ProviderFlags;
upWhereChanged:
Result := ((pfInWhere in ProviderFlags) and not VarIsClear(NewValue)) or
(pfInKey in ProviderFlags);
upWhereKeyOnly:
Result := pfInKey in ProviderFlags;
end;
end;
end;
procedure TSQLResolver.GenWhereSQL(Tree: TUpdateTree; SQL: TStrings; Params: TParams;
GenUpdateMode: TUpdateMode; Alias: string);
function AddField(Field: TField; InObject: Boolean): Boolean;
var
i: Integer;
BindText: string;
s:string;
oP:TParam;
begin
Result := False;
with PSQLInfo(Tree.Data)^ do
begin
if Field.DataType = ftADT then
begin
for i := 0 to TObjectField(Field).FieldCount - 1 do
if AddField(TObjectField(Field).Fields[i], True) then
Result := True;
end else
if UseFieldInWhere(Field, GenUpdateMode) and (Field.DataSize < dsMaxStringSize) then
begin
Result := True;
if InObject then
begin
if VarIsNull(Field.OldValue) then
BindText := Format(' %s.%s is null and', [Alias, { Do not localize }
QuoteFullName(Field.FullName, QuoteChar)])
else
begin
BindText := Format(' %s.%s = ? and',[Alias, { Do not localize }
QuoteFullName(Field.FullName, QuoteChar)]);
TParam(Params.Add).AssignFieldValue(Field, Field.OldValue);
end;
end else
begin
if VarIsNull(Field.OldValue) or (not IsSQLBased and
(Field.DataType = ftString) and (Length(Field.OldValue) = 0)) then
BindText := Format(' %s%s%s%1:s is null and', { Do not localize }
[PSQLInfo(Tree.Data)^.QuotedTableDot, QuoteChar, Field.Origin])
else
begin
BindText := Format(' %s%s%s%1:s = ? and', { Do not localize }
[PSQLInfo(Tree.Data)^.QuotedTableDot, QuoteChar, Field.Origin]);
IF (Field.DataType = ftDateTime) then
begin
//***********************唐荨荨于2005-07-21调整****************************
s:=SQLTimeStampToStr('yyyy-mm-dd hh:mm:ss.zzz',VarToSQLTimeStamp(Field.OldValue));
if rightstr(s,4)='.000' then
begin
TParam(Params.Add).AssignFieldValue(Field, Field.OldValue);
end
else
begin
oP:=TParam(Params.Add);
oP.DataType:=ftString;
oP.Size:=length(s);
oP.Value:=s;
oP.Bound:=true;
end;
//***********************************************************************
end
else
TParam(Params.Add).AssignFieldValue(Field, Field.OldValue);
end;
end;
SQL.Add(BindText);
end;
end;
end;
var
I: Integer;
TempStr: string;
Added: Boolean;
begin
with PSQLInfo(Tree.Data)^ do
begin
SQL.Add('where');
Added := False;
for I := 0 to Tree.Delta.FieldCount - 1 do
if AddField(Tree.Delta.Fields[I], Alias = NestAlias) then
Added := True;
if not Added then
DatabaseError(SNoKeySpecified);
{ Remove last ' and'}
TempStr := SQL[SQL.Count-1];
SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 4);
end;
end;
procedure TSQLResolver.GenInsertSQL(Tree: TUpdateTree; SQL: TStrings;
Params: TParams);
procedure AddField(Field: TField; var FieldLine, ParamLine: string);
var
i: Integer;
TempStr: string;
Value: Variant;
begin
with PSQLInfo(Tree.Data)^ do
begin
if Field.DataType in [ftADT, ftArray] then
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := Format('%s%s(', [ParamLine, TObjectField(Field).ObjectType]);
for i := 0 to TObjectField(Field).FieldCount - 1 do
AddField(TObjectField(Field).Fields[i], TempStr, ParamLine);
ParamLine := Copy(ParamLine, 1, Length(ParamLine) - 2) + '), ';
end else
if (Field.DataType = ftDataSet) and (TObjectField(Field).ObjectType <> '') then
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := Format('%s%s(), ', [ParamLine, TDataSetField(Field).ObjectType]);
end else
if (UseFieldInUpdate(Field)) or ((Field.ParentField <> nil) and (Field.ParentField.DataType in [ftADT, ftArray, ftReference]) and VarIsNull(Field.Value)) then
begin
if (Field.DataType = ftOraBlob) and (not InformixLob) then
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := ParamLine + 'EMPTY_BLOB(), ' { Do not localize }
end
else if (Field.DataType = ftOraClob) and (not InformixLob) then
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := ParamLine + 'EMPTY_CLOB(), ' { Do not localize }
end else
if (Field.ParentField <> nil) and VarIsNull(Field.Value) then
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := ParamLine + 'null, ';
end else
begin
FieldLine := Format('%s%s%s%s%2:s, ', [FieldLine, PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]);
ParamLine := ParamLine + '?, ';
Value := Field.NewValue;
if VarIsClear(Value) then Value := Field.OldValue;
TParam(Params.Add).AssignFieldValue(Field, Value);
end;
end;
end;
end;
var
I, J: Integer;
FieldLine, ParamLine: string;
OraLobs: Integer;
Value: Variant;
begin
OraLobs := 0;
with PSQLInfo(Tree.Data)^ do
begin
SQL.Clear;
if Tree.IsNested then
begin
SQL.Add(Format('insert into the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar),
PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias])); { Do not localize }
GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
SQL.Add(')');
end else
SQL.Add(Format('insert into %s', [QuotedTable])); { Do not localize }
FieldLine := ' (';
ParamLine := FieldLine;
for I := 0 to Tree.Delta.FieldCount - 1 do
begin
AddField(Tree.Delta.Fields[I], FieldLine, ParamLine);
if Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob] then
if (not InformixLob) then
Inc(OraLobs);
end;
if not Tree.IsNested then
SQL.Add(Copy(FieldLine, 1, Length(FieldLine)-2)+')');
SQL.Add('values');
SQL.Add(Copy(ParamLine, 1, Length(ParamLine)-2)+')');
if OraLobs > 0 then
begin
SQL.Add(' RETURNING '); { Do not localize }
J := OraLobs;
for I := 0 to Tree.Delta.FieldCount - 1 do
if (Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob] )
and UseFieldInUpdate(Tree.Delta.Fields[I]) then
begin
Dec(J);
SQL.Add(Format('%s ', [Tree.Delta.Fields[I].FullName]));
if J > 0 then SQL.Add(', ');
Value := Tree.Delta.Fields[I].NewValue;
if VarIsClear(Value) then Value := Tree.Delta.Fields[I].OldValue;
TParam(Params.Add).AssignFieldValue(Tree.Delta.Fields[I], Value)
end;
SQL.Add('INTO '); { Do not localize }
while OraLobs > 0 do
begin
SQL.Add('? ');
Dec(OraLobs);
if OraLobs > 0 then SQL.Add(', ');
end;
end;
end;
end;
procedure TSQLResolver.GenDeleteSQL(Tree: TUpdateTree; SQL: TStrings;
Params: TParams; Alias: string);
begin
with PSQLInfo(Tree.Data)^ do
begin
SQL.Clear;
if Tree.IsNested then
begin
Alias := NestAlias;
SQL.Add(Format('delete the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar),
PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias])); { Do not localize }
GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
SQL.Add(Format(') %s',[Alias]));
end else
SQL.Add(Format('delete from %s %s', [QuotedTable, Alias])); { Do not localize }
GenWhereSQL(Tree, SQL, Params, Provider.UpdateMode, Alias);
end;
end;
procedure TSQLResolver.GenUpdateSQL(Tree: TUpdateTree; SQL: TStrings;
Params: TParams; Alias: string);
procedure AddField(Field: TField; InObject, InArray: Boolean);
var
i: Integer;
TempStr: string;
Value: Variant;
NoParam: Boolean;
begin
NoParam := False;
with PSQLInfo(Tree.Data)^ do
begin
if Field.DataType = ftADT then
begin
if InArray then
SQL.Add(Format(' %s(',[TObjectField(Field).ObjectType]));
for i := 0 to TObjectField(Field).FieldCount - 1 do
AddField(TObjectField(Field).Fields[i], True, InArray);
if InArray then
begin
TempStr := SQL[SQL.Count-1];
SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
SQL.Add('),');
end;
end
else if Field.DataType = ftArray then
begin
SQL.Add(Format('%s = %s(',[Field.FullName, TObjectField(Field).ObjectType]));
for i := 0 to TObjectField(Field).FieldCount - 1 do
AddField(TObjectField(Field).Fields[i], InObject, True);
TempStr := SQL[SQL.Count-1];
SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
SQL.Add('),');
end
else if InArray then
begin
SQL.Add(' ?,');
Value := Field.NewValue;
if VarIsClear(Value) then Value := Field.OldValue;
TParam(Params.Add).AssignFieldValue(Field, Value);
end
else if UseFieldInUpdate(Field) then
begin
if (Field.DataType = ftOraClob) and (not InformixLob) then
begin
NoParam := True;
if InObject then
SQL.Add(Format(' %s.%s = EMPTY_CLOB(),', [Alias, QuoteFullName(Field.FullName, QuoteChar), { Do not localize }
Field.FullName])) else
SQL.Add(Format(' %s%s%s%1:s = EMPTY_CLOB(),', [PSQLInfo(Tree.Data)^.QuotedTableDot, { Do not localize }
QuoteChar, Field.Origin]));
end
else if (Field.DataType = ftOraBlob) and (not InformixLob) then
begin
NoParam := True;
if InObject then
SQL.Add(Format(' %s.%s = EMPTY_BLOB(),', [Alias, QuoteFullName(Field.FullName, QuoteChar), { Do not localize }
Field.FullName])) else
SQL.Add(Format(' %s%s%s%1:s = EMPTY_BLOB(),', [PSQLInfo(Tree.Data)^.QuotedTableDot, { Do not localize }
QuoteChar, Field.Origin]));
end
else if InObject then
SQL.Add(Format(' %s.%s = ?,', [Alias, QuoteFullName(Field.FullName, QuoteChar),
Field.FullName])) else
SQL.Add(Format(' %s%s%s%1:s = ?,', [PSQLInfo(Tree.Data)^.QuotedTableDot,
QuoteChar, Field.Origin]));
if not NoParam then
begin
Value := Field.NewValue;
if VarIsClear(Value) then Value := Field.OldValue;
TParam(Params.Add).AssignFieldValue(Field, Value);
end;
end;
end;
end;
var
I, J: integer;
TempStr: string;
OraLobs: Integer;
Value: Variant;
begin
OraLobs := 0;
with PSQLInfo(Tree.Data)^ do
begin
if Tree.IsNested then
begin
Alias := NestAlias;
SQL.Add(Format('update the (select %s FROM %s %s',[QuoteFullName(Tree.Name, QuoteChar), { Do not localize }
PSQLInfo(Tree.Parent.Data).QuotedTable, DefAlias]));
GenWhereSQL(Tree.Parent, SQL, Params, upWhereKeyOnly, DefAlias);
SQL.Add(Format(') %s set',[Alias])); { Do not localize }
end else
SQL.Add(Format('update %s %s set', [QuotedTable, Alias])); { Do not localize }
for I := 0 to Tree.Delta.FieldCount - 1 do
begin
if (Tree.Delta.Fields[i].DataType in [ftOraClob, ftOraBlob]) and
UseFieldInUpdate(Tree.Delta.Fields[I]) then
if (not InformixLob) then
Inc(OraLobs);
AddField(Tree.Delta.Fields[i], Alias = NestAlias, False);
end;
{ Remove last ',' }
TempStr := SQL[SQL.Count-1];
SQL[SQL.Count-1] := Copy(TempStr, 1, Length(TempStr) - 1);
GenWhereSQL(Tree, SQL, Params, Provider.UpdateMode, Alias);
if OraLobs > 0 then
begin
SQL.Add(' RETURNING '); { Do not localize }
J := OraLobs;
for I := 0 to Tree.Delta.FieldCount - 1 do
if (Tree.Delta.Fields[I].DataType in [ftOraClob, ftOraBlob])
and UseFieldInUpdate(Tree.Delta.Fields[I]) then
begin
Dec(J);
SQL.Add(Format('%s ', [Tree.Delta.Fields[I].FullName]));
if J > 0 then SQL.Add(', ');
Value := Tree.Delta.Fields[I].NewValue;
if VarIsClear(Value) then Value := Tree.Delta.Fields[I].OldValue;
TParam(Params.Add).AssignFieldValue(Tree.Delta.Fields[I], Value)
end;
SQL.Add('INTO '); { Do not localize }
while OraLobs > 0 do
begin
SQL.Add('? ');
Dec(OraLobs);
if OraLobs > 0 then SQL.Add(', ');
end;
end;
end;
end;
procedure TSQLResolver.GenSelectSQL(Tree: TUpdateTree; SQL: TStrings;
Params: TParams; Alias: string; Mode: TUpdateMode = upWhereKeyOnly);
var
i: Integer;
Temp: string;
begin
with PSQLInfo(Tree.Data)^ do
begin
SQL.Add('select');
for i := 0 to Tree.Delta.FieldCount - 1 do
with Tree.Delta.Fields[i] do
if not (DataType in [ftDataSet, ftReference]) and (FieldKind = fkData)
and (pfInWhere in ProviderFlags) then
SQL.Add(Format(' %s%s%s%1:s,',[QuotedTableDot, QuoteChar, Origin]));
{ Remove last ',' }
Temp := SQL[SQL.Count-1];
SQL[SQL.Count-1] := Copy(Temp, 1, Length(Temp) - 1);
SQL.Add(Format(' from %s %s',[QuotedTable, Alias])); { Do not localize }
GenWhereSQL(Tree, SQL, Params, Mode, Alias);
end;
end;
{ TLocalAppServer }
constructor TLocalAppServer.Create(AProvider: TCustomProvider);
begin
inherited Create;
FProvider := AProvider;
end;
destructor TLocalAppServer.Destroy;
begin
if FProviderCreated then FProvider.Free;
inherited Destroy;
end;
constructor TLocalAppServer.Create(ADataset: TDataset);
begin
inherited Create;
FProvider := TDatasetProvider.Create(nil);
TDatasetProvider(FProvider).Dataset := ADataset;
FProviderCreated := True;
end;
function TLocalAppServer.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
end;
function TLocalAppServer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
end;
function TLocalAppServer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TLocalAppServer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TLocalAppServer.AS_ApplyUpdates(const ProviderName: WideString;
Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;
var OwnerData: OleVariant): OleVariant;
begin
Result := FProvider.ApplyUpdates(Delta, MaxErrors, ErrorCount, OwnerData);
end;
function TLocalAppServer.AS_GetRecords(const ProviderName: WideString; Count: Integer;
out RecsOut: Integer; Options: Integer; const CommandText: WideString;
var Params, OwnerData: OleVariant): OleVariant;
begin
Result := FProvider.GetRecords(Count, RecsOut, Options, CommandText, Params,
OwnerData);
end;
function TLocalAppServer.AS_GetProviderNames: OleVariant;
begin
Result := NULL;
end;
function TLocalAppServer.AS_DataRequest(const ProviderName: WideString;
Data: OleVariant): OleVariant;
begin
Result := FProvider.DataRequest(Data);
end;
function TLocalAppServer.AS_GetParams(const ProviderName: WideString;
var OwnerData: OleVariant): OleVariant;
begin
Result := FProvider.GetParams(OwnerData);
end;
function TLocalAppServer.AS_RowRequest(const ProviderName: WideString;
Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant;
begin
Result := FProvider.RowRequest(Row, RequestType, OwnerData);
end;
procedure TLocalAppServer.AS_Execute(const ProviderName: WideString;
const CommandText: WideString; var Params, OwnerData: OleVariant);
begin
FProvider.Execute(CommandText, Params, OwnerData);
end;
function TLocalAppServer.InterfaceSupportsErrorInfo(const iid: TGUID): HResult;
begin
if IsEqualGUID(IAppServer, iid) then
Result := S_OK else
Result := S_FALSE;
end;
function TLocalAppServer.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
begin
{$IFDEF MSWINDOWS}
Result := HandleSafeCallException(ExceptObject, ExceptAddr, IAppServer, '', '');
{$ENDIF}
{$IFDEF LINUX}
if ExceptObject is Exception then
begin
SetSafeCallExceptionMsg(Exception(ExceptObject).Message);
SetSafeCallExceptionAddr(ExceptAddr);
Result := HResult($8000FFFF);
end
else
Result := inherited SafeCallException(ExceptObject, ExceptAddr);
{$ENDIF}
end;
end.