unit Un_TpsCachedUpdates;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, RxQuery,Math,Consts;

type

   TcuOnUpdateRecord = procedure (DataSet:TDataSet) of object;
   TcuOnBeforeApplyCancel = procedure (Sender:TObject;var DoAction:Boolean) of object;
   TcuOnAfterApplyCancel = procedure (Sender:TObject) of object;

   TpsCachedUpdates = class;

   TDataSetMember = class (TPersistent)
   private
       FpsCachedUpdates:TpsCachedUpdates;
       FDataSet:TDBDataSet;
       FCheckUpdate:Boolean;
       FCheckDelete:Boolean;
       procedure SetDataSet(const Value: TDBDataSet);
   published
       property DataSet:TDBDataSet read FDataSet write SetDataSet;
       property CheckUpdate:Boolean read FCheckUpdate write FCheckUpdate;
       property CheckDelete:Boolean read FCheckDelete write FCheckDelete;
   end;

   TpsCachedUpdates = class (TComponent)
   private
      FDataSets:array[1..10] of TDataSetMember;
      FRxQuery:TRxQuery;
      FSQLScript:TSQLScript;
      FOnDelete: TcuOnUpdateRecord;
      FOnInsert: TcuOnUpdateRecord;
      FOnUpdate: TcuOnUpdateRecord;
      FOnAfterApply: TcuOnAfterApplyCancel;
      FOnBeforApply: TcuOnBeforeApplyCancel;
      FOnBeforCancel: TcuOnBeforeApplyCancel;
      FOnAfterCancel: TcuOnAfterApplyCancel;
      FCanModifyOnly,FCanDeleteOnly: Integer;
      function GetTransaction: Boolean;
      procedure SetTransaction(const Value: Boolean);
      function GetDataset(Index:Integer):TDataSetMember;
      procedure SetDataSet(Index:Integer;Value:TDataSetMember);
      procedure FillSQL(DataSet: TDataSet;UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
      function GetDatabaseName: string;
      procedure SetDatabaseName(const Value: string);
      procedure SetOnDelete(const Value: TcuOnUpdateRecord);
      procedure SetOnInsert(const Value: TcuOnUpdateRecord);
      procedure SetOnUpdate(const Value: TcuOnUpdateRecord);
      procedure SetOnAfterApply(const Value: TcuOnAfterApplyCancel);
      procedure SetOnAfterCancel(const Value: TcuOnAfterApplyCancel);
      procedure SetOnBeforeApply(const Value: TcuOnBeforeApplyCancel);
      procedure SetOnBeforeCancel(const Value: TcuOnBeforeApplyCancel);
   protected
      procedure Notification(AComponent: TComponent; Operation: TOperation);override;
   public
      constructor Create(AOwner:TComponent);override;
      destructor Destroy;override;
      procedure ApplyUpdates(FirstSQLs,LastSQLs:array of TStrings;ToScript:TSQLScript=nil);
      procedure CancelUpdates;
      function UpdatesPending(Index:Integer=-1):Boolean;
      procedure GetLastSQL(var SQL:TStrings);
   published
      property DataSet01:TDataSetMember index 01 read GetDataSet write SetDataSet;
      property DataSet02:TDataSetMember index 02 read GetDataSet write SetDataSet;
      property DataSet03:TDataSetMember index 03 read GetDataSet write SetDataSet;
      property DataSet04:TDataSetMember index 04 read GetDataSet write SetDataSet;
      property DataSet05:TDataSetMember index 05 read GetDataSet write SetDataSet;
      property DataSet06:TDataSetMember index 06 read GetDataSet write SetDataSet;
      property DataSet07:TDataSetMember index 07 read GetDataSet write SetDataSet;
      property DataSet08:TDataSetMember index 08 read GetDataSet write SetDataSet;
      property DataSet09:TDataSetMember index 09 read GetDataSet write SetDataSet;
      property DataSet10:TDataSetMember index 10 read GetDataSet write SetDataSet;
      property Transaction:Boolean read GetTransaction write SetTransaction;
      property DatabaseName:string read GetDatabaseName write SetDatabaseName;
      property OnDelete:TcuOnUpdateRecord read FOnDelete write SetOnDelete;
      property OnInsert:TcuOnUpdateRecord read FOnInsert write SetOnInsert;
      property OnUpdate:TcuOnUpdateRecord read FOnUpdate write SetOnUpdate;
      property OnBeforApply:TcuOnBeforeApplyCancel read FOnBeforApply write SetOnBeforeApply;
      property OnAfterApply:TcuOnAfterApplyCancel read FOnAfterApply write SetOnAfterApply;
      property OnBeforCancel:TcuOnBeforeApplyCancel read FOnBeforCancel write SetOnBeforeCancel;
      property OnAfterCancel:TcuOnAfterApplyCancel read FOnAfterCancel write SetOnAfterCancel;
      property CanModifyOnly:Integer read FCanModifyOnly write FCanModifyOnly default 1;
      property CanDeleteOnly:Integer read FCanDeleteOnly write FCanDeleteOnly default 1;
   end;

function Get16(Str:string):string;
function RealSQL(Q:TRxQuery):string;

implementation

uses RxStrUtils,Variants;

{$R TpsCachedUpdates.RES}
//Перевод строки в шестнадцатеричный вид
function Get16(Str:string):string;
var
  I:Integer;
begin
  Result:='0x';
  for I:=1 to Length(Str) do
    Result:=Result+Dec2Hex(Ord(Str[I]),2);
end;


//Замена макросов в RxQuery работает неправильно.
function RealSQL(Q:TRxQuery):string;
const
   ValidChars:set of Char=['A'..'Z','a'..'z','_'];
type
   TValue = record
               Start,Length:Integer;
               Text:string;
            end;
   PValue = ^TValue;
var
   I,K:Integer;
   OutStr:string;
   Pref:Char;
   pMacro:TParam;
   lBuf:TList;
   Value:PValue;
begin
   lBuf:=TList.Create;
   try
      Pref:=Q.MacroChar;
      OutStr:=Q.SQL.Text;
      I:=Pos(Pref,OutStr);
      while I>0 do begin
        K:=I+1;
        while (OutStr[K] in ValidChars) do Inc(K);
        pMacro:=Q.Macros.FindParam(Copy(OutStr,I+1,K-I-1));
        if (pMacro<>nil) then begin
          New(Value);
          with Value^ do begin
            Start:=I;
            Length:=K-I;
            if pMacro.IsNull or (pMacro.AsString='0=0') then
              Text:='NULL'
            else Text:=pMacro.AsString;
          end;
          lBuf.Add(Value);
        end;
        I:=Pos(Pref,Copy(OutStr,K,Length(OutStr)-K+1));
        if (I>0) then I:=I+K-1;
      end;
      K:=0;
      for I:=0 to lBuf.Count-1 do begin
        Value:=PValue(lBuf[I]);
        Delete(OutStr,Value^.Start+K,Value^.Length);
        Insert(Value^.Text,OutStr,Value^.Start+K);
        K:=K+Length(Value^.Text)-Value^.Length;
      end;
      Result:=OutStr;
   finally
      for I:=0 to lBuf.Count-1 do
        Dispose(PValue(lBuf[I]));
      lBuf.Free;
   end;
end;



{ TCachedUpdates }

procedure TpsCachedUpdates.ApplyUpdates(FirstSQLs,LastSQLs:array of TStrings;ToScript:TSQLScript=nil);
var
   I:Integer;
   Buf:TUpdateRecordEvent;
   DoApply:Boolean;
begin
   try
      DoApply:=UpdatesPending;
      if DoApply and Assigned(FOnBeforApply) then
         FOnBeforApply(Self,DoApply);
      if DoApply then
       begin
          FSQLScript.SQL.Clear;
          for I:=Low(FirstSQLs) to High(FirstSQLs) do
           begin
              FSQLScript.SQL.AddStrings(FirstSQLs[I]);
              FSQLScript.SQL.Add (FSQLScript.Term);
           end;
          for I:=Low(FDataSets) to High(FDataSets) do
           if (FDataSets[I].DataSet<>nil) and (FDataSets[I].DataSet.Active) and (FDataSets[I].DataSet.UpdatesPending) then
            begin
               Buf:=FDataSets[I].DataSet.OnUpdateRecord;
               FDataSets[I].DataSet.OnUpdateRecord:=FillSQL;
               try
                  FDataSets[I].DataSet.ApplyUpdates;
                  FDataSets[I].DataSet.OnUpdateRecord:=Buf;
               except
                  FDataSets[I].DataSet.OnUpdateRecord:=Buf;
                  Raise;
               end;
            end;
          for I:=Low(LastSQLs) to High(LastSQLs) do
           begin
              FSQLScript.SQL.AddStrings(LastSQLs[I]);
              FSQLScript.SQL.Add (FSQLScript.Term);
           end;
          if Trim(FSQLScript.SQL.Text)<>'' then
           begin
              if ToScript=nil then
                 FSQLScript.ExecSQL
              else ToScript.SQL.AddStrings(FSQLScript.SQL);
              FSQLScript.SQL.Add(Name);
              FSQLScript.SQL.Add(FormatDateTime('dd_mm_yyyy__hh_nn_ss',Now));
              FSQLScript.SQL.SaveToFile (ExtractFilePath(Application.ExeName)+'LastSQL.txt');
           end;
          for I:=Low(FDataSets) to High(FDataSets) do
           if (FDataSets[I].DataSet<>nil) and (FDataSets[I].DataSet.Active) then
              FDataSets[I].DataSet.CommitUpdates;
          if Assigned(FOnAfterApply) then
             FOnAfterApply(Self);
       end;
   except
    on E:Exception do
     begin
        FSQLScript.SQL.Add(Name);
        FSQLScript.SQL.Add('Error:'+E.Message);
        FSQLScript.SQL.SaveToFile (ExtractFilePath(Application.ExeName)+Name+'_'+FormatDateTime('dd_mm_yyyy__hh_nn_ss',Now)+'.txt');
        Raise;
     end;
   end;
end;

procedure TpsCachedUpdates.CancelUpdates;
var
   I:Integer;
   DoCancel:Boolean;
begin
   DoCancel:=True;
   if DoCancel and Assigned(FOnBeforCancel) then
       FOnBeforCancel(Self,DoCancel);
   if DoCancel then
    begin
       for I:=Low(FDataSets) to High(FDataSets) do
        if (FDataSets[I].DataSet<>nil) and (FDataSets[I].DataSet.Active) then
           FDataSets[I].DataSet.CancelUpdates;
       if Assigned(FOnAfterCancel) then
           FOnAfterCancel(Self);
    end;
end;

constructor TpsCachedUpdates.Create(AOwner: TComponent);
var
   I:Integer;
begin
  FCanModifyOnly:=1;
  FCanDeleteOnly:=1;
  for I:=Low(FDataSets) to High(FDataSets) do
   begin
      FDataSets[I]:=TDataSetMember.Create;
      FDataSets[I].FpsCachedUpdates:=Self;
   end;
  inherited;
  FRxQuery:=TRxQuery.Create(Self);
  with FRxQuery do
   begin
      MacroChar:=':';
   end;
  FSQLScript:=TSQLScript.Create(Self);
  with FSQLScript do
   begin
      SemicolonTerm:=False;
   end;
  Transaction:=True;
end;

procedure TpsCachedUpdates.FillSQL(DataSet: TDataSet;UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
var
   Data:TDBDataSet;
   UpdData:TUpdateSQL;
   I:Integer;
   CurParam:TParam;
   CurField:string;
   CurValue:Variant;
   CheckUpdate,CheckDelete:Boolean;
begin
   case UpdateKind of
      ukModify:if Assigned(FOnUpdate) then FOnUpdate(DataSet);
      ukInsert:if Assigned(FOnInsert) then FOnInsert(DataSet);
      ukDelete:if Assigned(FOnDelete) then FOnDelete(DataSet);
   end;
   Data:=TDBDataSet(DataSet);
   UpdData:=TUpdateSQL(Data.UpdateObject);
   FRxQuery.SQL.Assign (UpdData.SQL[UpdateKind]);
   for I:=0 to FRxQuery.MacroCount-1 do
    begin
       CurParam:=FRxQuery.Macros[I];
       if UpperCase(Copy(CurParam.Name,1,Min(4,Length(CurParam.Name))))<>'OLD_' then
        begin
           CurField:=CurParam.Name;
           CurValue:=Data.FieldByName(CurField).NewValue;
        end
       else
        begin
           CurField:=Copy(CurParam.Name,5,Length(CurParam.Name)-4);
           CurValue:=Data.FieldByName(CurField).OldValue;
        end;
       if (Data.FieldByName(CurField) is TBlobField)and(TBlobField(Data.FieldByName(CurField)).BlobType<>ftMemo)or(Data.FieldByName(CurField) is TStringField) then
        begin
           CurParam.DataType:=ftString;
           if (CurValue=null) then
              CurParam.AsString:='NULL'
           else CurParam.AsString:=Get16(String(CurValue));
        end
       else if (Data.FieldByName(CurField) is TBlobField)and(TBlobField(Data.FieldByName(CurField)).BlobType=ftMemo) then
        begin
           CurParam.DataType:=ftString;
           if (CurValue=null) then
              CurParam.AsString:='NULL'
           else CurParam.AsString:='convert(varchar(8000),'+Get16(String(CurValue))+')';
        end
       else
        case VarType(CurValue) of
          varNull   :begin
                        CurParam.DataType:=ftString;
                        CurParam.AsString:='NULL';
                     end;
          varString :begin
                        CurParam.DataType:=ftString;
                        CurParam.AsString:=''''+String(CurValue)+'''';
                     end;
          varDate   :begin
                        CurParam.DataType:=ftString;
                        CurParam.AsString:=''''+FormatDateTime('dd-mm-yyyy hh:nn:ss',TDateTime(CurValue))+'''';
                     end;
          varInteger :begin
                         CurParam.DataType:=ftInteger;
                         CurParam.AsInteger:=Integer(CurValue);
                      end;
          varDouble,
          varCurrency:begin
                         CurParam.DataType:=ftCurrency;
                         CurParam.AsFloat:=Double(CurValue);
                      end;
        else
           CurParam.DataType:=Data.FieldByName(CurField).DataType;
           CurParam.Value:=CurValue;
        end;
    end;
    //Заполнение параметров значениями
    // RxQuery неправильно заполняет Macro,если например :id1,:id.
    FRxQuery.SQL.Text:=RealSQL(FRxQuery);
    
    CheckUpdate:=False;
    CheckDelete:=False;
    if (UpdateKind in [ukModify,ukDelete]) and (FCanModifyOnly>=0) then
     for I:=Low(FDataSets) to High(FDataSets) do
      if (FDataSets[I].DataSet<>nil)and(FDataSets[I].DataSet=DataSet) then
       begin
          CheckUpdate:=FDataSets[I].CheckUpdate and (UpdateKind=ukModify);
          CheckDelete:=FDataSets[I].CheckDelete and (UpdateKind=ukDelete);
          Break;
       end;

    with FSQLScript.SQL do
     begin
        if CheckUpdate or CheckDelete then
         begin
            Add('--DataSet.Name='+DataSet.Owner.Name+'.'+DataSet.Name);
            Add('SET NoCount ON            ');
            Add('DECLARE @Count AS INT     ');
         end;
        AddStrings(FRxQuery.RealSQL);
        if CheckUpdate then
         begin
            Add('SELECT @Count=@@ROWCOUNT  ');
            Add('IF @COUNT=0               ');
            Add('   RAISERROR (''Нет записей для обновления.'',16,1)   ');
            Add('ELSE IF @COUNT<>'+IntToStr(FCanModifyOnly));
            Add(' BEGIN                    ');
            Add('    DECLARE @Msg AS VARCHAR(50)   ');
            Add('    SELECT @Msg='''+DataSet.Owner.Name+'.'+DataSet.Name+':Попытка обновить ''+CONVERT(VARCHAR(10),@Count)+'' записи.''  ');
            Add('    RAISERROR (@Msg,16,1) ');
            Add(' END                      ');
            Add('SET NOCOUNT OFF           ');
         end
        else if CheckDelete then
         begin
            Add('SELECT @Count=@@ROWCOUNT  ');
            Add('IF @COUNT=0               ');
            Add('   RAISERROR (''Нет записей для удаления.'',16,1)   ');
            Add('ELSE IF @COUNT<>'+IntToStr(FCanDeleteOnly));
            Add(' BEGIN                    ');
            Add('    DECLARE @Msg AS VARCHAR(50)   ');
            Add('    SELECT @Msg='''+DataSet.Owner.Name+'.'+DataSet.Name+':Попытка удалить ''+CONVERT(VARCHAR(10),@Count)+'' записи.''  ');
            Add('    RAISERROR (@Msg,16,1) ');
            Add(' END                      ');
            Add('SET NOCOUNT OFF           ');
         end;
        Add(FSQLScript.Term);
     end;
    UpdateAction:=uaApplied;
end;

function TpsCachedUpdates.GetDatabaseName: string;
begin
   Result:=FSQLScript.DatabaseName;
end;

function TpsCachedUpdates.GetDataset(Index: Integer): TDataSetMember;
begin
   Result:=FDataSets[Index];
end;

procedure TpsCachedUpdates.GetLastSQL(var SQL: TStrings);
begin
   SQL.Assign (FSQLScript.SQL);
end;

function TpsCachedUpdates.GetTransaction: Boolean;
begin
   Result:=FSQLScript.Transaction;
end;

function TpsCachedUpdates.UpdatesPending(Index:Integer=-1): Boolean;
var
   I:Integer;
   CurData:TDBDataSet;
begin
   if Index=-1 then
    begin
       Result:=False;
       for I:=Low(FDataSets) to High(FDataSets) do
        begin
           CurData:=FDataSets[I].DataSet;
           if (CurData<>nil)and(CurData.Active) then
            begin
               if (CurData.State in [dsEdit,dsInsert]) then
                  CurData.Post;
               Result:=Result or (CurData.UpdatesPending);
            end;
        end;
    end
   else begin
      CurData:=FDataSets[Low(FDataSets)+Index].DataSet;
      Result:=(CurData<>nil)and(CurData.Active)and(CurData.UpdatesPending);
   end;
end;

procedure TpsCachedUpdates.SetDatabaseName(const Value: string);
begin
   FSQLScript.DatabaseName:=Value;
end;

procedure TpsCachedUpdates.SetDataSet(Index: Integer;Value:TDataSetMember);
var
   I:Integer;
begin
   if (csLoading in ComponentState) then
       FDataSets[Index]:=Value
   else begin
      if FDataSets[Index].DataSet=Value.DataSet then Exit;
      if Value.DataSet=nil then
       begin
          FDataSets[Index]:=nil;
          Exit;
       end;
      //Проверка
      for I:=Low(FDataSets) to High(FDataSets) do
         if (FDataSets[I].DataSet=Value.DataSet) then
            Raise Exception.Create('Этот компонент уже есть.');
      if not Value.DataSet.CachedUpdates then
         Raise Exception.Create('У компонента св-о CachedUpdates должно быть True')
      else if Value.DataSet.UpdateObject=nil then
         Raise Exception.Create('У компонента должен быть UpdateObject');
      //Запись
      FDataSets[Index]:=Value;
   end;
end;

procedure TpsCachedUpdates.SetOnAfterApply(const Value: TcuOnAfterApplyCancel);
begin
  FOnAfterApply := Value;
end;

procedure TpsCachedUpdates.SetOnAfterCancel(const Value: TcuOnAfterApplyCancel);
begin
  FOnAfterCancel := Value;
end;

procedure TpsCachedUpdates.SetOnBeforeApply(const Value: TcuOnBeforeApplyCancel);
begin
  FOnBeforApply := Value;
end;

procedure TpsCachedUpdates.SetOnBeforeCancel(const Value: TcuOnBeforeApplyCancel);
begin
  FOnBeforCancel := Value;
end;

procedure TpsCachedUpdates.SetOnDelete(const Value: TcuOnUpdateRecord);
begin
  FOnDelete := Value;
end;

procedure TpsCachedUpdates.SetOnInsert(const Value: TcuOnUpdateRecord);
begin
  FOnInsert := Value;
end;

procedure TpsCachedUpdates.SetOnUpdate(const Value: TcuOnUpdateRecord);
begin
  FOnUpdate := Value;
end;

procedure TpsCachedUpdates.SetTransaction(const Value: Boolean);
begin
   FSQLScript.Transaction:=Value;
end;

{ TDataSetMember }

procedure TDataSetMember.SetDataSet(const Value: TDBDataSet);
var
   I:Integer;
begin
   if (csLoading in FpsCachedUpdates.ComponentState) then
       FDataSet:=Value
   else begin
      if FDataSet=Value then Exit;
      if Value=nil then
       begin
          FDataSet:=nil;
          FCheckUpdate:=False;
          FCheckDelete:=False;
          Exit;
       end;
      //Проверка
      for I:=Low(FpsCachedUpdates.FDataSets) to High(FpsCachedUpdates.FDataSets) do
         if (FpsCachedUpdates.FDataSets[I].DataSet=Value) then
            Raise Exception.Create('Этот компонент уже есть.');
      if not Value.CachedUpdates then
         Raise Exception.Create('У компонента св-о CachedUpdates должно быть True')
      else if Value.UpdateObject=nil then
         Raise Exception.Create('У компонента должен быть UpdateObject');
      //Запись
      FDataSet:=Value;
      FCheckUpdate:=True;
      FCheckDelete:=True;
   end;
end;

destructor TpsCachedUpdates.Destroy;
var
   I:Integer;
begin
  inherited;
  for I:=Low(FDataSets) to High(FDataSets) do
     FDataSets[I].Free;
end;

procedure TpsCachedUpdates.Notification(AComponent: TComponent;Operation: TOperation);
var
   I:Integer;
begin
  inherited;
  if (Operation=opRemove)and(AComponent is TDBDataSet) then
   for I:=Low(FDataSets) to High(FDataSets) do
    if (FDataSets[I].DataSet=AComponent) then
     begin
        FDataSets[I].DataSet:=nil;
        Break;
     end;
end;

end.