dxjs_dbvalidation.pas

Well known and usefull component for delphi 7

   fLoaded := False;
   if (AOwner = nil) or
      not (AOwner is TForm) then begin
      raise Exception.Create('Parent must be TForm!');
      Exit;
   end;
   fParent := AOwner as TForm;
   fOzzHook:=Nil;
   if (csDesigning in ComponentState) or
      (csLoading in ComponentState) then Exit;
   fOzzHook := TOzzPersist.Create(nil);
   fOzzHook.Suspended:=False;
   fOzzHook.ComponentList := TStringList.Create;
   fOzzHook.OnExitValidate := InternalExitValidate;
   fOzzHook.OnEnterValidate := InternalEnterValidate;
   fOzzHook.BeforePostValidate := InternalBeforePostValidate;
   fOzzHook.JavaScript := TDXJavaScript.Create(nil);
   fOzzHook.JavaScript.AddRoutine('GetFieldValue', @__GetFieldValue);
   fOzzHook.JavaScript.AddRoutine('SetFocus', @__SetFocus);
   fOzzHook.JavaScript.AddRoutine('RaiseError', @__RaiseError);
   BinTree := TDXBinarySearchTree.Create(DXCompareFunc, DXDisposeProc);
end;

destructor TDXJS_DBValidation.Destroy;
var
   I: Integer;
   DSList: TStringList;
   OriginalInstance: Pointer;

begin
(*
   if not (csDesigning in ComponentState) then begin
      try
         fOzzHook.ComponentList.Free;
         DSList := TStringList.Create;
         DSList.Sorted := True;
         DSList.Duplicates := dupIgnore;
         for I := 0 to fParent.ComponentCount - 1 do begin
            if GetPropInfo(fParent.Components[I], 'Datasource') <> nil then begin
               OriginalInstance := GetObjectProp(fParent.Components[I], 'DataSource');
               if OriginalInstance <> nil then
                  if DSList.IndexOf(TDataSource(OriginalInstance).DataSet.Name) < 0 then begin
                     DSList.Add(TDataSource(OriginalInstance).DataSet.Name);
                     fOzzHook.RemoveDatasetJavaScript(TDataSource(OriginalInstance).DataSet,
                        TDataSource(OriginalInstance).DataSet.Name);
                  end;
            end;
            fOzzHook.RemoveJavaScript(fParent.Components[I],
               fParent.Components[I].Name);
         end;
         fOzzHook.Free;
         DSList.Free;
//      BinTree.Clear;
//      BinTree.Free;
      except
         ;
      end;
   end;
*)
   inherited Destroy;
end;

procedure TDXJS_DBValidation.InternalExitValidate(Sender: TObject);
var
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
{$ifdef VARIANTS}
   MyNull:Variant;
{$endif}

begin
   if fOzzHook.Suspended then exit;
//   DXString.ProcessWindowsMessageQueue;
   New(Query);
   Query^.ComponentName := TComponent(Sender).Name;
   BinTreeItem := BinTree.Find(Query);
   Dispose(Query);
   with fOzzHook do begin
      JavaScript.AddObject('self', TComponent(Sender));
      JavaScript.AddProperty(TComponent(Sender).ClassType,
         'dbvalue',
         @__GetText,
         @__SetText);
      if not JavaScript.Compiled then JavaScript.Compile;
//      JavaScript.SourceDump;
{$ifdef VARIANTS}
      MyNull:=Null;
      JavaScript.CallFunction(TComponent(Sender).Name + 'OnExit', MyNull);
{$else}
      JavaScript.CallFunction(TComponent(Sender).Name + 'OnExit', Null);
{$endif}
      if Assigned(BinTreeItem) then begin
         if Assigned(BinTreeItem^.OldOnExit) then
            BinTreeItem^.OldOnExit(Sender);
      end;
//      DXString.ProcessWindowsMessageQueue;
   end;
end;

procedure TDXJS_DBValidation.InternalEnterValidate(Sender: TObject);
var
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
{$ifdef VARIANTS}
   MyNull:Variant;
{$endif}

begin
   if fOzzHook.Suspended then exit;
//   DXString.ProcessWindowsMessageQueue;
   New(Query);
   Query^.ComponentName := TComponent(Sender).Name;
   BinTreeItem := BinTree.Find(Query);
   Dispose(Query);
   with fOzzHook do begin
      JavaScript.AddObject('self', TComponent(Sender));
      JavaScript.AddProperty(TComponent(Sender).ClassType,
         'dbvalue',
         @__GetText,
         @__SetText);
      if not JavaScript.Compiled then JavaScript.Compile;
//      JavaScript.SourceDump;
{$ifdef VARIANTS}
      MyNull:=Null;
      JavaScript.CallFunction(TComponent(Sender).Name + 'OnEnter', MyNull);
{$else}
      JavaScript.CallFunction(TComponent(Sender).Name + 'OnEnter', Null);
{$endif}
      if Assigned(BinTreeItem) then begin
         if Assigned(BinTreeItem^.OldOnEnter) then
            BinTreeItem^.OldOnEnter(Sender);
      end;
//      DXString.ProcessWindowsMessageQueue;
   end;
end;

procedure TDXJS_DBValidation.InternalBeforePostValidate(DataSet: TDataSet);
var
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
{$ifdef VARIANTS}
   MyNull:Variant;
{$endif}

begin
   if fOzzHook.Suspended then exit;
//   DXString.ProcessWindowsMessageQueue;
   New(Query);
   Query^.ComponentName := DataSet.Name;
   BinTreeItem := BinTree.Find(Query);
   Dispose(Query);
   with fOzzHook do begin
      if not JavaScript.Compiled then JavaScript.Compile;
//      JavaScript.SourceDump;
      try
{$ifdef VARIANTS}
         MyNull:=Null;
         JavaScript.CallFunction(DataSet.Name + 'BeforePost', MyNull);
{$else}
         JavaScript.CallFunction(DataSet.Name + 'BeforePost', Null);
{$endif}
         if Assigned(BinTreeItem) then begin
            if Assigned(BinTreeItem^.OldBeforePost) then
               BinTreeItem^.OldBeforePost(DataSet);
         end;
      except
         raise;
      end;
//      DXString.ProcessWindowsMessageQueue;
   end;
end;

procedure TDXJS_DBValidation.LinkFieldsandDatasets(SourceCode: TStream);
var
   I: Integer;
   RunTimeMethod: TMethod;
   RunTimeMethod2: TMethod;
   RunTimeMethod3: TMethod;
   PropInfo: PPropInfo;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
   DSList: TStringList;
   Done: Boolean;
   Ws: string;
{$IFDEF DUMP_BASE_SCRIPT}
   StrList: TStringList;
{$ENDIF}
{$ifdef VARIANTS}
   MyNull:Variant;
{$endif}

begin
   if (csDesigning in ComponentState) or
      (csLoading in ComponentState) then Exit;
//   DXString.ProcessWindowsMessageQueue;
   BinTree.Clear;
// skim the source for "blank" functions and drop them!
   fOzzHook.ComponentList.Clear;
   if SourceCode.Size > 0 then begin

      DSList := TStringList.Create;
      DSList.LoadFromStream(SourceCode);
      Done := False;
      I := 0;
      while not Done do begin
         Ws := DSList[I];
      // drop blank function??
         if Lowercase(FetchByChar(Ws, #32, False)) = 'function' then begin
            fOzzHook.ComponentList.Add(FetchByChar(Ws, #32, False));
            Ws := DSList[I + 1];
            if Ws = '{' then begin
               Ws := DSList[I + 2];
               if Ws = '}' then begin
                  DSList.Delete(I);
                  DSList.Delete(I);
                  DSList.Delete(I);
                  fOzzHook.ComponentList.Delete(fOzzHook.ComponentList.Count - 1);
                  Dec(I);
               end;
            end;
         end
      // drop commented lines??
         else begin
            Ws := DSList[I];
            if Copy(Ws, 1, 2) = '//' then begin
               DSList.Delete(I);
               Dec(I);
            end
            else
               if Ws = '' then begin
                  DSList.Delete(I);
                  Dec(I);
               end;
         end;
         Inc(I);
         if I > DSList.Count - 5 then Done := True;
      end;
      TMemoryStream(SourceCode).Clear;
      DSList.SaveToStream(SourceCode);
      SourceCode.Seek(0, 0);
      DSList.Free;
   end;

{$IFDEF DUMP_BASE_SCRIPT}
   StrList := TStringList.Create;
{$ENDIF}
   if SourceCode.Size > 0 then begin
      fOzzHook.JavaScript.LoadFromStream(SourceCode);
      fOzzHook.JavaScript.Compile;
      fLoaded := True;
   end;

   New(BinTreeItem);
   BinTreeItem^.ComponentName := 'PARENT_FORM';
   BinTreeItem^.DBAncestorLike := -1;
   BinTreeItem^.OriginalInstance := fParent;
   BinTreeItem^.DataFieldName := '';
   BinTreeItem^.OldOnExit := nil;
   BinTreeItem^.OldOnEnter := nil;
   BinTreeItem^.OldBeforePostHooked:=False;
   BinTreeItem^.OldBeforePost := nil;
   BinTree.Insert(BinTreeItem);

   DSList := TStringList.Create;
   DSList.Sorted := True;
   DSList.Duplicates := dupIgnore;

   PropInfo := GetPropInfo(fOzzHook, 'OnExitValidate');
   if PropInfo <> nil then begin
      RunTimeMethod := GetMethodProp(fOzzHook, 'OnExitValidate');
      RunTimeMethod2 := GetMethodProp(fOzzHook, 'OnEnterValidate');
      RunTimeMethod3 := GetMethodProp(fOzzHook, 'BeforePostValidate');
   end;
   for I := 0 to fParent.ComponentCount - 1 do begin
      New(Query);
      Query^.ComponentName := fParent.Components[I].Name;
      BinTreeItem := BinTree.Find(Query);
      Dispose(Query);
      if Assigned(BinTreeItem) then BinTree.Delete(BinTreeItem);
      New(BinTreeItem);
      BinTreeItem^.ComponentName := fParent.Components[I].Name;
      try
// Will Only Link what is acceptable, otherwise exception out!
         PropInfo := GetPropInfo(fParent.Components[I], 'DataSource');
         BinTreeItem^.DBAncestorLike := -1;
         if PropInfo <> nil then begin

            BinTreeItem^.OriginalInstance := GetObjectProp(fParent.Components[I], 'DataSource');
            if DSList.IndexOf(TDataSource(BinTreeItem^.OriginalInstance).DataSet.Name) < 0 then begin
               DSList.Add(TDataSource(BinTreeItem^.OriginalInstance).DataSet.Name);
               fOzzHook.ApplyDatasetJavaScript(TDataSource(BinTreeItem^.OriginalInstance).DataSet,
                  TDataSource(BinTreeItem^.OriginalInstance).DataSet.Name, RunTimeMethod3);
{$IFDEF DUMP_BASE_SCRIPT}
               StrList.Add('function ' + TDataSource(BinTreeItem^.OriginalInstance).DataSet.Name + 'BeforePost()');
               StrList.Add('{');
               StrList.Add('}');
               StrList.Add('');
{$ENDIF}
            end;
            BinTreeItem^.DBAncestorLike := 6;
            try
               BinTreeItem^.DataFieldName := GetStrProp(fParent.Components[I], 'Datafield');
               BinTreeItem^.OldOnExit := nil;
               BinTreeItem^.OldOnEnter := nil;
               BinTreeItem^.OldBeforePost := nil;
               BinTreeItem^.OldBeforePostHooked:=False;
               BinTree.Insert(BinTreeItem);
               fOzzHook.ApplyJavaScript(fParent.Components[I],
                  fParent.Components[I].Name, RunTimeMethod, RunTimeMethod2);
{$IFDEF DUMP_BASE_SCRIPT}
               StrList.Add('function ' + fParent.Components[I].Name + 'OnExit()');
               StrList.Add('{');
               StrList.Add('}');
               StrList.Add('');
               StrList.Add('function ' + fParent.Components[I].Name + 'OnEnter()');
               StrList.Add('{');
               StrList.Add('}');
               StrList.Add('');
{$ENDIF}
            except
               StrList.Insert(0, '// Not Added: ' + fParent.Components[I].Name);
            end;
         end;
      except
         if BinTreeItem^.DBAncestorLike < 0 then Dispose(BinTreeItem);
      end;
   end;
   fOzzHook.JavaScript.AddObject(fParent.Name,
      fParent);
{$ifdef VARIANTS}
   MyNull:=Null;
   fOzzHook.JavaScript.CallFunction('OnFormCreate', MyNull);
{$else}
   fOzzHook.JavaScript.CallFunction('OnFormCreate', Null);
{$endif}
//   DXString.ProcessWindowsMessageQueue;

{$IFDEF DUMP_BASE_SCRIPT}
   StrList.Insert(0, '//////////////////////////////////////////////////////////');
   while DSList.Count > 0 do begin
      StrList.Insert(0, '// Datasource: ' + DSList[0]);
      DSList.Delete(0);
   end;
   StrList.Insert(0, '// Primary Form Instance: ' + fParent.Name);
   StrList.Insert(0, '// Special Objects...');
   StrList.Insert(0, '//////////////////////////////////////////////////////////');
   StrList.Insert(0, '// Skeleton Created ' + DateTimeToStr(Now));
   StrList.Insert(0, '// Auto-created Skeleton, contains ' + IntegerToString(BinTree.Count) + ' supported variable(s)');
   StrList.Insert(0, '//////////////////////////////////////////////////////////');
   StrList.Add('function OnFormCreate()');
   StrList.Add('{');
   StrList.Add('}');
   StrList.Add('');
   StrList.SaveToFile('C:\' + fParent.Name + '.jsbase');
   StrList.Free;
{$ENDIF}
   DSList.Free;
end;

procedure TDXJS_DBValidation.OnActivateRehook;
var
   I: Integer;
   DSList: TStringList;
   RunTimeMethod3: TMethod;
   PropInfo: PPropInfo;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
   OriginalInstance:Pointer;

begin
   if (csDesigning in ComponentState) or
      (csLoading in ComponentState) then Exit;
   DSList := TStringList.Create;
   DSList.Sorted := True;
   DSList.Duplicates := dupIgnore;
   PropInfo := GetPropInfo(fOzzHook, 'OnExitValidate');
   if PropInfo <> nil then begin
      RunTimeMethod3 := GetMethodProp(fOzzHook, 'BeforePostValidate');
   end;
   for I := 0 to fParent.ComponentCount - 1 do begin
try
      OriginalInstance:=GetObjectProp(fParent.Components[I],'DataSource');
      If OriginalInstance<>Nil then Begin
         New(Query);
         Query^.ComponentName :=TDataSource(OriginalInstance).DataSet.Name;
         BinTreeItem := BinTree.Find(Query);
         Dispose(Query);
            if DSList.IndexOf(TDataSource(OriginalInstance).DataSet.Name)<0 then begin
               If Assigned(BinTreeItem) then begin
                  BinTree.Delete(BinTreeItem);
               End;
               DSList.Add(TDataSource(OriginalInstance).DataSet.Name);
               fOzzHook.ApplyDatasetJavaScript(TDataSource(OriginalInstance).DataSet,
                  TDataSource(OriginalInstance).DataSet.Name, RunTimeMethod3);
            end;
      End;
except
      ;
end;
   end;
//   ShowMessage('Rehooked:'+#13+DSList.Text);
   DSList.Free;
end;

procedure TDXJS_DBValidation.SetfSuspend(value:boolean);
Begin
   if Assigned(fOzzHook) then fOzzHook.Suspended:=Value;
End;

end.