www.pudn.com > FIBPlus.v6.9.5.forD5-2007.FS.rar > DSContainer.pas, change:2009-02-06,size:11401b
{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases }
{ }
{ FIBPlus is based in part on the product }
{ Free IB Components, written by Gregory H. Deatz for }
{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
{ mailto:gdeatz@hlmdd.com }
{ }
{ Copyright (c) 1998-2007 Devrace Ltd. }
{ Written by Serge Buzadzhy (buzz@devrace.com) }
{ }
{ ------------------------------------------------------------- }
{ FIBPlus home page: http://www.fibplus.com/ }
{ FIBPlus support : http://www.devrace.com/support/ }
{ ------------------------------------------------------------- }
{ }
{ Please see the file License.txt for full license information }
{***************************************************************}
unit DSContainer;
interface
{$I FIBPlus.inc}
uses
{$IFDEF WINDOWS}
Windows, Messages, SysUtils, Classes, DB,pFIBDataInfo;
{$ENDIF}
{$IFDEF LINUX}
Types, SysUtils, Classes, DB;
{$ENDIF}
type
TKindDataSetEvent = ( deBeforeOpen , deAfterOpen,deBeforeClose ,
deAfterClose,deBeforeInsert,deAfterInsert,deBeforeEdit,deAfterEdit,
deBeforePost,deAfterPost,deBeforeCancel,deAfterCancel,deBeforeDelete,
deAfterDelete,deBeforeScroll,deAfterScroll,deOnNewRecord,deOnCalcFields,
deBeforeRefresh,deAfterRefresh
);
TKindDataSetError=(
deOnEditError,deOnPostError,deOnDeleteError
);
TOnApplyDefaultValue = procedure(DataSet:TDataSet; Field:TField; var Applied:boolean) of object;
TOnApplyFieldRepository=procedure(DataSet:TDataSet;Field:TField;FieldInfo:TpFIBFieldInfo) of object;
TOnDataSetEvent =procedure (DataSet:TDataSet;Event:TKindDataSetEvent) of object;
TOnDataSetError =procedure (DataSet:TDataSet;Event:TKindDataSetError;
E: EDatabaseError; var Action: TDataAction
) of object;
TOnCompareFieldValues=
function (Field:TField;const S1,S2:variant;var Compared:boolean ):integer of object;
{$IFDEF USE_DEPRECATE_METHODS2}
TUserEvent =procedure (Sender:TObject;Receiver:TDataSet;const EventName:string;
var Info :string
) of object;
{$ENDIF}
TDataSetsContainer = class;
TDataSetsContainer = class(TComponent)
private
FActive :boolean;
FMasterContainer:TDataSetsContainer;
FOnDataSetEvent:TOnDataSetEvent;
FOnApplyDefaultValue:TOnApplyDefaultValue;
FOnApplyFieldRepository:TOnApplyFieldRepository;
FOnDataSetError:TOnDataSetError;
FOnCompareFieldValues:TOnCompareFieldValues;
{$IFDEF USE_DEPRECATE_METHODS2}
FOnUserEvent :TUserEvent;
{$ENDIF}
vDataSetsList :TList;
FIsGlobalContainer:boolean;
procedure SetMasterContainer(Value:TDataSetsContainer);
procedure CheckCircularMaster(Value:TDataSetsContainer);
procedure SetIsGlobalContainer(const Value: boolean);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner:Tcomponent);override;
destructor Destroy;override;
procedure AddDataSet(Value:TDataSet);
procedure RemoveDataSet(Value:TDataSet);
{$IFDEF USE_DEPRECATE_METHODS2}
procedure NotifyDataSets(Sender:TObject;const UDA,UDE:string;var Info :string); dynamic; deprecated;
// (UDA - user defined address)
// (UDE - user defined Event)
{$ENDIF}
procedure DataSetEvent(DataSet:TDataSet;Event:TKindDataSetEvent);
procedure DoOnApplyDefaultValue(DataSet:TDataSet;Field:TField; var Applied:boolean);
procedure DoOnApplyFieldRepository(DataSet:TDataSet;Field:TField;FieldInfo:TpFIBFieldInfo);
procedure DataSetError(DataSet:TDataSet;Event:TKindDataSetError;
E: EDatabaseError; var Action: TDataAction
);
function DataSetCompareFieldValues(DataSet:TDataSet;
Field:TField;const S1,S2:variant;var Res:integer
):boolean;
{$IFDEF USE_DEPRECATE_METHODS2}
procedure UserEvent(Sender:TObject;Receiver:TDataSet;const EventName:string; var Info :string); deprecated;
{$ENDIF}
function DataSetCount:integer;
function DataSet(Index:integer):TDataSet;
published
property Active:boolean read FActive write FActive default true;
property OnDataSetEvent :TOnDataSetEvent read FOnDataSetEvent write FOnDataSetEvent;
property OnDataSetError :TOnDataSetError read FOnDataSetError write FOnDataSetError;
{$IFDEF USE_DEPRECATE_METHODS2}
property OnUserEvent :TUserEvent read FOnUserEvent write FOnUserEvent;
{$ENDIF}
property OnApplyDefaultValue:TOnApplyDefaultValue read FOnApplyDefaultValue write FOnApplyDefaultValue;
property OnApplyFieldRepository:TOnApplyFieldRepository read FOnApplyFieldRepository write FOnApplyFieldRepository;
property MasterContainer:TDataSetsContainer read FMasterContainer write SetMasterContainer;
property OnCompareFieldValues:TOnCompareFieldValues read FOnCompareFieldValues write FOnCompareFieldValues;
property IsGlobalContainer:boolean read FIsGlobalContainer write SetIsGlobalContainer default false;
end;
function GlobalContainer:TDataSetsContainer;
implementation
uses
StrUtil, pFIBDataSet, FIBConsts;
threadvar
vGlobalContainer:TDataSetsContainer;
function GlobalContainer:TDataSetsContainer;
begin
Result:=vGlobalContainer
end;
constructor TDataSetsContainer.Create(AOwner:Tcomponent);//override;
begin
inherited Create(AOwner);
FActive :=true;
FMasterContainer :=nil;
vDataSetsList :=TList.Create;
end;
destructor TDataSetsContainer.Destroy;//override;
begin
inherited Destroy;
vDataSetsList.Free;
end;
procedure TDataSetsContainer.Notification(AComponent: TComponent; Operation: TOperation); //override;
begin
if (Operation=opRemove) then
begin
if AComponent<>FMasterContainer then vDataSetsList.Remove(AComponent);
if AComponent=FMasterContainer then FMasterContainer:=nil;
end;
inherited Notification(AComponent,Operation)
end;
procedure TDataSetsContainer.DataSetEvent(DataSet:TDataSet;Event:TKindDataSetEvent);
begin
if Assigned(FMasterContainer) then FMasterContainer.DataSetEvent(DataSet,Event);
if Active then
begin
if Assigned(FOnDataSetEvent) then FOnDataSetEvent(DataSet,Event)
end;
end;
procedure TDataSetsContainer.DoOnApplyDefaultValue(DataSet:TDataSet;Field:TField; var Applied:boolean);
begin
if Assigned(FMasterContainer) then FMasterContainer.DoOnApplyDefaultValue(DataSet,Field,Applied);
if Active then
begin
if Assigned(FOnApplyDefaultValue) then FOnApplyDefaultValue(DataSet,Field,Applied)
end;
end;
procedure TDataSetsContainer.DataSetError(DataSet:TDataSet;Event:TKindDataSetError;
E: EDatabaseError; var Action: TDataAction);
begin
if Assigned(FMasterContainer) then FMasterContainer.DataSetError(DataSet,Event,E,Action);
if Active then
begin
if Assigned(FOnDataSetError) then FOnDataSetError(DataSet,Event,E,Action)
end;
end;
{$IFDEF USE_DEPRECATE_METHODS2}
procedure TDataSetsContainer.UserEvent(Sender:TObject;Receiver:TDataSet;const EventName:string;var Info:string);
begin
if Assigned(FMasterContainer) then FMasterContainer.UserEvent(Sender,Receiver,EventName,Info);
if Active then
begin
if Assigned(FOnUserEvent) then FOnUserEvent(Sender,Receiver,EventName,Info)
end;
end;
{$ENDIF}
procedure TDataSetsContainer.SetMasterContainer(Value:TDataSetsContainer);
var i:integer;
begin
CheckCircularMaster(Value);
if FMasterContainer<>nil then
for i:=0 to Pred(vDataSetsList.Count) do
FMasterContainer.RemoveDataSet(TDataSet(vDataSetsList[i]));
FMasterContainer:=Value;
if Value<>nil then
begin
Value.FreeNotification(Self);
for i:=0 to Pred(vDataSetsList.Count) do
Value.AddDataSet(TDataSet(vDataSetsList[i]))
end;
end;
procedure TDataSetsContainer.CheckCircularMaster(Value:TDataSetsContainer);
var CurContainer:TDataSetsContainer;
begin
if Value = Self then raise Exception.Create(SFIBErrorCircularLinks);
CurContainer:=Value;
while CurContainer<>nil do
if CurContainer.MasterContainer=Self then raise Exception.Create(SFIBErrorCircularLinks)
else CurContainer:=CurContainer.MasterContainer;
end;
procedure TDataSetsContainer.AddDataSet(Value:TDataSet);
begin
if Value<>nil then
begin
if vDataSetsList.IndexOf(Value)=-1 then vDataSetsList.Add(Value);
if MasterContainer<>nil then MasterContainer.AddDataSet(Value);
Value.FreeNotification(Self)
end;
end;
procedure TDataSetsContainer.RemoveDataSet(Value:TDataSet);
begin
if vDataSetsList.IndexOf(Value)<>-1 then vDataSetsList.Remove(Value);
if MasterContainer<>nil then MasterContainer.RemoveDataSet(Value);
end;
{$IFDEF USE_DEPRECATE_METHODS2}
procedure TDataSetsContainer.NotifyDataSets(Sender:TObject;const UDA,UDE:string;var Info :string);
var i:integer;
begin
for i:=0 to Pred(vDataSetsList.Count) do
begin
if (UDA='') or
WildStringCompare(
FastUpperCase(TDataSet(vDataSetsList[i]).Owner.Name+'.'+TDataSet(vDataSetsList[i]).Name),
FastUpperCase(UDA)
)
then
if (TDataSet(vDataSetsList[i]) is TpFibDataSet) then
with TpFibDataSet(vDataSetsList[i]) do
if (ReceiveEvents.Count=0) or (WldIndexOf(ReceiveEvents,UDE,false)<>-1 )then
DoUserEvent(Sender,UDE,Info)
end;
end;
{$ENDIF}
function TDataSetsContainer.DataSetCount:integer;
begin
Result :=vDataSetsList.Count
end;
function TDataSetsContainer.DataSet(Index:integer):TDataSet;
begin
if (Index<vDataSetsList.Count) and (Index>-1) then
Result :=TDataSet(vDataSetsList[Index])
else
Result :=nil
end;
function TDataSetsContainer.DataSetCompareFieldValues(DataSet: TDataSet;
Field: TField; const S1, S2: variant; var Res:integer): boolean;
begin
if Assigned(FOnCompareFieldValues) then
Res:=FOnCompareFieldValues(Field,S1, S2,Result)
else
Result := False;
end;
procedure TDataSetsContainer.SetIsGlobalContainer(const Value: boolean);
begin
FIsGlobalContainer := Value;
if not (csDesigning in ComponentState)then
begin
if Value then
begin
if Assigned(vGlobalContainer) and (vGlobalContainer<>Self) then
vGlobalContainer.FIsGlobalContainer:=False;
vGlobalContainer:=Self
end
else
if not Value and (vGlobalContainer=Self) then
vGlobalContainer:=nil
end;
end;
procedure TDataSetsContainer.DoOnApplyFieldRepository(DataSet: TDataSet;
Field: TField; FieldInfo: TpFIBFieldInfo);
begin
if Assigned(FMasterContainer) then FMasterContainer.DoOnApplyFieldRepository(DataSet,Field,FieldInfo);
if Active then
begin
if Assigned(FOnApplyFieldRepository) then FOnApplyFieldRepository(DataSet,Field,FieldInfo)
end;
end;
initialization
vGlobalContainer:=nil;
end.