dxjs_dbvalidation.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: TDXJS_DBValidation
//       Author: Alexander Baranovsky ([e-mail])
//               G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 2002, 2004
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
// Code Version: (3rd Generation)
// ========================================================================
//  Description: on-the-fly implementation of validation hooks for all
//  data-aware components on the form. Implements a Frm OnCreate event,
//  slips a JavaScript OnEnter() and OnExit() hook into the components. If
//  an existing event already existing, the address is stored, and upon a
//  successful JavaScript validation, the old address is then called.
// ========================================================================
////////////////////////////////////////////////////////////////////////////
unit DXJS_DBValidation;
interface

{$I DXJavaScript.def}

uses
{$ifdef VARIANTS}
   variants,
{$endif}
   DB,
   Dialogs,
   Classes,
   Forms;

{$DEFINE DUMP_BASE_SCRIPT}

type
   TDXJS_DBValidation = class(TComponent)
   private
    { Private declarations }
      fParent: TForm;
      fLoaded: Boolean;
      fSuspend: Boolean;
   protected
    { Protected declarations }
      procedure InternalExitValidate(Sender: TObject);
      procedure InternalEnterValidate(Sender: TObject);
      procedure InternalBeforePostValidate(DataSet: TDataSet);
      procedure SetfSuspend(value:boolean);
   public
    { Public declarations }
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      procedure LinkFieldsandDatasets(SourceCode: TStream);
      procedure OnActivateRehook;
   published
    { Published declarations }
      property LoadedAndReady: Boolean read fLoaded write fLoaded;
      property Suspend:Boolean read fSuspend write SetfSuspend;
   end;

procedure Register;

implementation

uses
   Controls, {setfocus}
   DBCtrls, TypInfo, SysUtils, {TMethod}
   DXString,
   DXJavaScript,
   DXBinaryTree;

type
   PDXLinkList = ^TDXLinkList;
   TDXLinkList = record
      ComponentName: string;
      DataFieldName: string;
      OriginalInstance: Pointer;
      OldOnExit: TNotifyEvent;
      OldOnEnter: TNotifyEvent;
      OldBeforePostHooked:Boolean;
      OldBeforePost: TDataSetNotifyEvent;
      DBAncestorLike: Integer;
         // -1= NOT ASSIGNED
         // 0 = like TDBEdit
         // 1 = like TDBText
         // 2 = like TDBComboBox
         // 3 = like TDBListBox
         // 4 = like TDDRadioGroup
   end;

   TOzzPersist = class(TComponent)
   private
      Suspended:Boolean;
      ComponentList: TStringList;
      fOnExitValidation: TNotifyEvent;
      fOnEnterValidation: TNotifyEvent;
      fBeforePostValidation: TDataSetNotifyEvent;
      procedure ApplyJavaScript(Component: TObject; ComponentName: string;
         RunTimeMethod, RunTimeMethod2: TMethod);
      procedure RemoveJavaScript(Component: TObject; ComponentName: string);
      procedure ApplyDatasetJavaScript(Component: TObject; ComponentName: string;
         RunTimeMethod3: TMethod);
      procedure RemoveDatasetJavaScript(Component: TObject; ComponentName: string);
   protected
      JavaScript: TDXJavaScript;
   public
      constructor Create(Owner: TComponent); override;
      destructor Destroy; override;
   published
      property OnExitValidate: TNotifyEvent read fOnExitValidation
         write fOnExitValidation;
      property OnEnterValidate: TNotifyEvent read fOnEnterValidation
         write fOnEnterValidation;
      property BeforePostValidate: TDataSetNotifyEvent read fBeforePostValidation
         write fBeforePostValidation;
   end;

var
   fOzzHook: TOzzPersist;
   BinTree: TDXBinarySearchTree;

procedure Register;
begin
   RegisterComponents('BPDX JavaScript', [TDXJS_DBValidation]);
end;

function __GetText(Instance: TObject; const Parameters: array of Variant): Variant;
begin
   result := TDBEdit(Instance).Text;
end;

function __SetText(Instance: TObject; const Parameters: array of Variant): Variant;
var
   S: string;
   BinTreeItem: PDXLinkList;
   DBE: TDBEdit;
   Query: PDXLinkList;

begin
   S := Parameters[0];
   New(Query);
   Query^.ComponentName := TComponent(Instance).Name;
   BinTreeItem := BinTree.Find(Query);
   Dispose(Query);
   if Assigned(BinTreeItem) then begin
      DBE := TDBEdit.Create(nil);
      DBE.DataField := BinTreeItem^.DataFieldName;
      SetObjectProp(DBE, 'Datasource', TDataSource(BinTreeItem^.OriginalInstance));
      DBE.DataSource.DataSet.FieldByName(BinTreeItem^.DataFieldName).AsString := S;
      DBE.Free;
   end;
//   SendKeys(S);
   Application.ProcessMessages;
////   SimulateKeystroke(VK_TAB, 0);
end;

function __GetFieldValue(const Parameters: array of Variant): Variant;
var
   BinTreeItem: PDXLinkList;
   DBE: TDBEdit;
   Query: PDXLinkList;

begin
   Result := '';
   if Length(Parameters) = 1 then begin
      New(Query);
      Query^.ComponentName := TDXJavaScript.ToString(Parameters[0]);
      BinTreeItem := BinTree.Find(Query);
      Dispose(Query);
      if Assigned(BinTreeItem) then begin
         DBE := TDBEdit.Create(nil);
         DBE.DataField := BinTreeItem^.DataFieldName;
         SetObjectProp(DBE, 'Datasource', TDataSource(BinTreeItem^.OriginalInstance));
         Result := DBE.DataSource.DataSet.FieldByName(BinTreeItem^.DataFieldName).AsString;
         DBE.Free;
      end;
   end;
end;

function __SetFocus(const Parameters: array of Variant): Variant;
var
   Ws: string;
   I: Integer;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;
   fParent: TForm;

begin
   New(Query);
   Query^.ComponentName := 'PARENT_FORM';
   BinTreeItem := BinTree.Find(Query);
   Dispose(Query);
   if Assigned(BinTreeItem) then begin
      fParent := BinTreeItem.OriginalInstance;
      Ws := TDXJavaScript.ToString(Parameters[0]);
      for I := 0 to fParent.ComponentCount - 1 do
         if fParent.Components[I].Name = Ws then begin
            TWinControl(fParent.Components[I]).SetFocus;
            Exit;
         end;
   end;
end;

function __RaiseError(const Parameters: array of Variant): Variant;
var
   Ws: string;

begin
   Ws := TDXJavaScript.ToString(Parameters[0]);
   raise Exception.create(Ws);
end;

constructor TOzzPersist.Create;
begin
   inherited Create(Owner);
   JavaScript := nil;
end;

destructor TOzzPersist.Destroy;
begin
   if Assigned(JavaScript) then JavaScript.Free;
   inherited Destroy;
end;

procedure TOzzPersist.ApplyJavaScript(Component: TObject; ComponentName: string;
   RunTimeMethod, RunTimeMethod2: TMethod);
var
   PropInfo: PPropInfo;
   DesignTimeMethod: TMethod;
   DesignTimeMethod2: TMethod;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;

begin
   try
      PropInfo := GetPropInfo(Component.ClassInfo, 'OnExit');
      if PropInfo <> nil then begin
         DesignTimeMethod := GetMethodProp(Component, 'OnExit');
         DesignTimeMethod2 := GetMethodProp(Component, 'OnEnter');
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'OnExit()') > -1 then
            if Assigned(DesignTimeMethod.Code) or
               Assigned(DesignTimeMethod.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then begin
                  BinTreeItem^.OldOnExit := TDBEdit(Component).OnExit;
               end;
               SetMethodProp(Component, 'OnExit', RunTimeMethod);
            end
            else
               SetMethodProp(Component, 'OnExit', RunTimeMethod);
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'OnEnter()') > -1 then
            if Assigned(DesignTimeMethod2.Code) or
               Assigned(DesignTimeMethod2.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then begin
                  BinTreeItem^.OldOnEnter := TDBEdit(Component).OnEnter;
               end;
               SetMethodProp(Component, 'OnEnter', RunTimeMethod2);
            end
            else
               SetMethodProp(Component, 'OnEnter', RunTimeMethod2);
      end;
   except
      ;
   end;
end;

procedure TOzzPersist.ApplyDatasetJavaScript(Component: TObject; ComponentName: string;
   RunTimeMethod3: TMethod);
var
   PropInfo: PPropInfo;
   DesignTimeMethod: TMethod;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;

begin
   try
      PropInfo := GetPropInfo(Component.ClassInfo, 'BeforePost');
      if PropInfo <> nil then begin
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'BeforePost()') > -1 then begin
            DesignTimeMethod := GetMethodProp(Component, 'BeforePost');
            if Assigned(DesignTimeMethod.Code) or
               Assigned(DesignTimeMethod.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then Exit;
               New(BinTreeItem);
               BinTreeItem^.ComponentName := ComponentName;
               BinTreeItem^.OriginalInstance := TDataSet(Component);
               BinTreeItem^.OldBeforePostHooked:=Assigned(TDataSet(Component).BeforePost);
               BinTreeItem^.OldBeforePost := TDataSet(Component).BeforePost;
               BinTree.Insert(BinTreeItem);
               SetMethodProp(Component, 'BeforePost', RunTimeMethod3);
            end
            else
               SetMethodProp(Component, 'BeforePost', RunTimeMethod3);
         end;
      end;
   except
      ;
   end;
end;

procedure TOzzPersist.RemoveJavaScript(Component: TObject; ComponentName: string);
var
   PropInfo: PPropInfo;
   DesignTimeMethod: TMethod;
   DesignTimeMethod2: TMethod;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;

begin
   try
      PropInfo := GetPropInfo(Component.ClassInfo, 'OnExit');
      if PropInfo <> nil then begin
         DesignTimeMethod := GetMethodProp(Component, 'OnExit');
         DesignTimeMethod2 := GetMethodProp(Component, 'OnEnter');
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'OnExit()') > -1 then
            if Assigned(DesignTimeMethod.Code) or
               Assigned(DesignTimeMethod.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then begin
                  TDBEdit(Component).OnExit := BinTreeItem^.OldOnExit;
               end;
            end;
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'OnEnter()') > -1 then
            if Assigned(DesignTimeMethod2.Code) or
               Assigned(DesignTimeMethod2.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then begin
                  TDBEdit(Component).OnEnter := BinTreeItem^.OldOnEnter;
               end;
            end;
      end;
   except
      ;
   end;
end;

procedure TOzzPersist.RemoveDataSetJavaScript(Component: TObject; ComponentName: string);
var
   PropInfo: PPropInfo;
   DesignTimeMethod: TMethod;
   BinTreeItem: PDXLinkList;
   Query: PDXLinkList;

begin
   try
      PropInfo := GetPropInfo(Component.ClassInfo, 'BeforePost');
      if PropInfo <> nil then begin
         DesignTimeMethod := GetMethodProp(Component, 'BeforePost');
         if fOzzHook.ComponentList.IndexOf(ComponentName + 'BeforePost()') > -1 then
            if Assigned(DesignTimeMethod.Code) or
               Assigned(DesignTimeMethod.Data) then begin
               New(Query);
               Query^.ComponentName := ComponentName;
               BinTreeItem := BinTree.Find(Query);
               Dispose(Query);
               if Assigned(BinTreeItem) then begin
                  TDataSet(Component).BeforePost := BinTreeItem^.OldBeforePost;
               end
               else TDataSet(Component).BeforePost := nil;
            end;
      end;
   except
      ;
   end;
end;

procedure DXDisposeProc(aData: pointer);
begin
//   FreeMem(PDXLinkList(aData)^.Data,PDXLinkList(aData)^.DataSize);
   Dispose(PDXLinkList(aData));
end;

function DXCompareFunc(aData1, aData2: pointer): integer;
begin
   if PDXLinkList(aData1)^.ComponentName < PDXLinkList(aData2)^.ComponentName
      then Result := -1
   else
      if PDXLinkList(aData1)^.ComponentName > PDXLinkList(aData2)^.ComponentName
      then Result := 1
      else Result := 0;
end;

constructor TDXJS_DBValidation.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);