unit fieldmap;
{$mode objfpc}
{$H+}
interface

uses SysUtils,Classes, db;

{ ---------------------------------------------------------------------
  TFieldMap
  ---------------------------------------------------------------------}

type
  EFieldMap = Class(EDatabaseError);

  { TFieldMap }

  TFieldMap = Class(TObject)
  private
    FDataset: TDataset;
    FFreeDataset: Boolean;
    FOldOnOpen : TDataSetNotifyEvent;
  Protected
    Procedure DoOnOpen(Sender : TDataset);
    Function FindField(FN : String) : TField;
    Function FieldByName(FN : String) : TField;
  Public
    Constructor Create(ADataset : TDataset; HookOnOpen : Boolean = False);
    Destructor Destroy; override;
    Procedure InitFields; virtual; abstract;
    Procedure LoadObject(AObject : TObject); virtual;
    Function GetFromField(F : TField; ADefault : Integer) : Integer; overload;
    Function GetFromField(F : TField; ADefault : String) : String; overload;
    Function GetFromField(F : TField; ADefault : Boolean) : Boolean; overload;
    Function GetFromField(F : TField; ADefault : TDateTime) : TDateTime; overload;
    Function GetFromField(F : TField; ADefault : Currency) : Currency; overload;
    Property Dataset : TDataset Read FDataset;
    Property FreeDataset : Boolean Read FFreeDataset Write FFreeDataset;
  end;
  TFieldMapClass = Class of TFieldMap;

  { TParamMap }

  TParamMap = Class(TObject)
  private
    FParams: TParams;
  Protected
    Function FindParam(FN : String) : TParam;
    Function ParamByName(FN : String) : TParam;
  Public
    Constructor Create(AParams : TParams);
    Procedure InitParams; virtual; abstract;
    Procedure SaveObject(AObject : TObject); virtual; abstract;
    Property Params : TParams Read FParams;
  end;

{ $INTERFACES CORBA}

  ITypeSafeDatasetAccess = Interface ['{67496051-66AA-474E-9CB2-A4AEAA7A2324}']
    // Property getter/setter
    procedure SetFreeDataset(AValue: Boolean);
    function GetFreeDataset: Boolean;
    function GetActive: boolean;
    function GetIsEmpty: boolean;
    function GetModified: Boolean;
    function GetRecNo: integer;
    function GetRecordCount: integer;
    function GetState: TDatasetState;
    function GetBOF: Boolean;
    function GetDataset: TDataset;
    function GetEOF: Boolean;
    procedure SetActive(AValue: boolean);
    procedure SetRecNo(AValue: integer);
    // Examine data
    function IsFieldNull(const FieldName : String) : boolean;
    function IsFieldNull(const FieldIndex : Integer) : boolean;
    // Open/close
    procedure Open;
    procedure Close;
    // Navigation
    procedure First;
    procedure Prior;
    Procedure Next;
    procedure Last;
    function Locate(const aKeyFields: string; const aKeyValues: Variant; aOptions: TLocateOptions = []): Boolean;
    function Lookup(const aKeyFields: string; const aKeyValues: Variant; const aResultFields: string): Variant;
    // Modification
    Procedure Append;
    Procedure Insert;
    Procedure Edit;
    Procedure Post;
    Procedure Delete;
    Procedure Cancel;
    Procedure ApplyUpdates;
    procedure ClearField(const FieldName : String);
    procedure ClearField(const FieldIndex : Integer);
    // Properties
    Property EOF : Boolean Read GetEOF;
    Property BOF : Boolean Read GetBOF;
    Property Dataset : TDataset Read GetDataset;
    property IsEmpty : boolean read GetIsEmpty;
    property State : TDatasetState read GetState;
    property RecordCount: integer read GetRecordCount;
    property RecNo : integer read GetRecNo write SetRecNo;
    property Active: boolean read GetActive write SetActive;
    Property Modified : Boolean Read GetModified;
    Property FreeDataset : Boolean Read GetFreeDataset Write SetFreeDataset;
  end;

  { TTypeSafeDatasetAccess }

  TTypeSafeDatasetAccess = Class(TInterfacedObject, ITypeSafeDatasetAccess)
  private
    FFieldMap: TFieldMap;
    function GetActive: boolean;
    function GetIsEmpty: boolean;
    function GetModified: Boolean;
    function GetFreeDataset: Boolean;
    function GetRecNo: integer;
    function GetRecordCount: integer;
    function GetState: TDatasetState;
    procedure SetActive(AValue: boolean);
    procedure SetFreeDataset(AValue: Boolean);
    procedure SetRecNo(AValue: integer);
  Protected
    Class Function FieldMapClass : TFieldMapClass; virtual; abstract;
    function GetBOF: Boolean;
    function GetDataset: TDataset;
    function GetEOF: Boolean;
    Property FieldMap : TFieldMap Read FFieldMap;
  Public
    Constructor Create(aDataset : TDataset; HookOnOpen : Boolean = True);
    Destructor Destroy; override;
    function  IsFieldNull(const FieldName : String) : boolean;
    function  IsFieldNull(const FieldIndex : Integer) : boolean;
    procedure ClearField(const FieldName : String);
    procedure ClearField(const FieldIndex : Integer);
    // Open/close
    procedure Open;
    procedure Close;
    // Navigation
    procedure First;
    procedure Prior;
    Procedure Next;
    procedure Last;
    function Locate(const aKeyFields: string; const aKeyValues: Variant; aOptions: TLocateOptions = []): Boolean;
    function Lookup(const aKeyFields: string; const aKeyValues: Variant;
      const aResultFields: string): Variant;
    // Modification
    Procedure Append;
    Procedure Insert;
    Procedure Edit;
    Procedure Post;
    Procedure Delete;
    Procedure Cancel;
    Procedure ApplyUpdates; virtual;

    Property EOF : Boolean Read GetEOF;
    Property BOF : Boolean Read GetBOF;
    Property Dataset : TDataset Read GetDataset;
    property IsEmpty : boolean read GetIsEmpty;
    property State : TDatasetState read GetState;
    property RecordCount: integer read GetRecordCount;
    property RecNo : integer read GetRecNo write SetRecNo;
    property Active: boolean read GetActive write SetActive;
    Property Modified : Boolean Read GetModified;
    Property FreeDataset : Boolean Read GetFreeDataset Write SetFreeDataset;
  end;

  { TBlobProxyStream }

  TBlobProxyStream = Class(TOwnerStream)
  Private
    FChangeCount : Integer;
    FOnChange: TNotifyEvent;
    function GetUpdating: Boolean;
  Protected
    Procedure DoChanged; virtual;
    Procedure BeginUpdate; virtual;
    Procedure EndUpdate; virtual;
    function GetSize: Int64; override;
    procedure SetSize(const aValue: Int64); override;
    function GetPosition: Int64; override;
    procedure SetPosition(const aValue: Int64); override;
  Public
    Constructor create; overload;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; overload;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    Property Updating : Boolean Read GetUpdating;
  end;


implementation


resourcestring
  SErrNoDataset = '%s: No dataset available.';
  SErrNoParamsForParam  = '%s: No params to search param "%s".';
  SErrNoObjectToLoad = '%s: No object to load';


function TBlobProxyStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := Source.Seek(Offset, Origin);
end;

procedure TBlobProxyStream.SetPosition(const aValue: Int64);
begin
  Source.Position := aValue;
end;

procedure TBlobProxyStream.SetSize(const aValue: Int64);
begin
  Source.Size := aValue;
  DoChanged;
end;

function TBlobProxyStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := Source.Write(Buffer, Count);
  DoChanged;
end;

procedure TBlobProxyStream.BeginUpdate;
begin
  inc(FChangeCount);
end;

constructor TBlobProxyStream.create;
begin
  Inherited Create(TMemoryStream.Create);
  SourceOwner:=True;
end;

procedure TBlobProxyStream.EndUpdate;
begin
  if FChangeCount > 0 then
    Dec(FChangeCount);
  DoChanged;
end;

function TBlobProxyStream.GetPosition: Int64;
begin
  Result := Source.Position;
end;

function TBlobProxyStream.GetSize: Int64;
begin
  Result := Source.Size;
end;

function TBlobProxyStream.GetUpdating: Boolean;
begin
  Result:=FChangeCount>0;
end;

procedure TBlobProxyStream.DoChanged;
begin
  if (FChangeCount = 0) and Assigned(OnChange) then
    OnChange(Self);
end;

function TBlobProxyStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := Source.Read(Buffer, Count);
end;

{ TTypeSafeDatasetAccess }

function TTypeSafeDatasetAccess.GetIsEmpty: boolean;
begin
  With Dataset do
    Result:=EOF and BOF;
end;

function TTypeSafeDatasetAccess.GetModified: Boolean;
begin
  Result:=Dataset.Modified;
end;

function TTypeSafeDatasetAccess.GetFreeDataset: Boolean;
begin
  Result:=FFieldMap.FreeDataset;
end;

function TTypeSafeDatasetAccess.GetActive: boolean;
begin
  Result:=Dataset.Active;
end;

function TTypeSafeDatasetAccess.GetRecNo: integer;
begin
  Result:=Dataset.RecNo;
end;

function TTypeSafeDatasetAccess.GetRecordCount: integer;
begin
  Result:=Dataset.RecordCount
end;

function TTypeSafeDatasetAccess.GetState: TDatasetState;
begin
  Result:=Dataset.State;
end;

procedure TTypeSafeDatasetAccess.SetActive(AValue: boolean);
begin
  Dataset.Active:=AValue;
end;

procedure TTypeSafeDatasetAccess.SetFreeDataset(AValue: Boolean);
begin
  FFieldMap.FreeDataset:=AValue;
end;

procedure TTypeSafeDatasetAccess.SetRecNo(AValue: integer);
begin
  Dataset.RecNo:=AValue;
end;

function TTypeSafeDatasetAccess.GetBOF: Boolean;
begin
  Result:=Dataset.BOF;
end;

function TTypeSafeDatasetAccess.GetDataset: TDataset;
begin
  Result:=FieldMap.Dataset;
end;

function TTypeSafeDatasetAccess.GetEOF: Boolean;
begin
  Result:=Dataset.EOF;
end;

procedure TTypeSafeDatasetAccess.ApplyUpdates;
begin
  // Needs to be implemented by descendents
end;

constructor TTypeSafeDatasetAccess.Create(aDataset: TDataset; HookOnOpen : Boolean = True);
begin
  FFieldMap:=FieldMapClass.Create(aDataset,HookOnOpen);
end;

destructor TTypeSafeDatasetAccess.Destroy;
begin
  FreeAndNil(FFieldMap);
  inherited Destroy;
end;

function TTypeSafeDatasetAccess.IsFieldNull(const FieldName: String): boolean;
begin
  Result:=Dataset.FieldByName(FieldName).IsNull;
end;

function TTypeSafeDatasetAccess.IsFieldNull(const FieldIndex: Integer): boolean;
begin
  Result:=Dataset.Fields[FieldIndex].IsNull;
end;

procedure TTypeSafeDatasetAccess.ClearField(const FieldName: String);
begin
  Dataset.FieldByName(FieldName).Clear;
end;

procedure TTypeSafeDatasetAccess.ClearField(const FieldIndex: Integer);
begin
  Dataset.Fields[FieldIndex].Clear;
end;

procedure TTypeSafeDatasetAccess.Open;
begin
  Dataset.Open;
end;

procedure TTypeSafeDatasetAccess.Close;
begin
  Dataset.Close;
end;

procedure TTypeSafeDatasetAccess.First;
begin
  Dataset.First;
end;

procedure TTypeSafeDatasetAccess.Append;
begin
  Dataset.Append;
end;

procedure TTypeSafeDatasetAccess.Insert;
begin
  Dataset.Insert;
end;

procedure TTypeSafeDatasetAccess.Edit;
begin
  Dataset.Edit;
end;

procedure TTypeSafeDatasetAccess.Next;
begin
  Dataset.Next;
end;

procedure TTypeSafeDatasetAccess.Last;
begin
  Dataset.Last;
end;

function TTypeSafeDatasetAccess.Locate(const aKeyFields: string;
  const aKeyValues: Variant; aOptions: TLocateOptions): Boolean;
begin
  Result:=Dataset.Locate(aKeyFields,AKeyValues,aOptions);
end;

function TTypeSafeDatasetAccess.Lookup(const aKeyFields: string;
  const aKeyValues: Variant; const aResultFields: string): Variant;
begin
  Result:=Dataset.Lookup(aKeyFields,aKeyValues,aResultFields);
end;

procedure TTypeSafeDatasetAccess.Prior;
begin
  Dataset.Prior;
end;

procedure TTypeSafeDatasetAccess.Post;
begin
  Dataset.Post;
end;

procedure TTypeSafeDatasetAccess.Delete;
begin
  Dataset.Delete;
end;

procedure TTypeSafeDatasetAccess.Cancel;
begin
  Dataset.Cancel;
end;

{ TParamMap }

function TParamMap.FindParam(FN: String): TParam;
begin
  Result:=FParams.FindParam(FN);
  {if (Result=Nil) then
    Writeln(ClassName,' param ',FN,' not found');}
end;

function TParamMap.ParamByName(FN: String): TParam;
begin
  If (FParams=Nil) then
    Raise Exception.CreateFmt(SErrNoParamsForParam,[ClassName,FN]);
  Result:=FParams.ParamByName(FN);
end;

constructor TParamMap.Create(AParams: TParams);
begin
  FParams:=AParams;
  InitParams;
end;

{ TFieldMap }

constructor TFieldMap.Create(ADataset: TDataset; HookOnOpen : Boolean = False);
begin
  if (ADataset=Nil) then
    Raise EFieldMap.CreateFmt(SErrNoDataset,[ClassName]);
  FDataset:=ADataset;
  if HookOnOpen then
    begin
    FOldOnOpen:=FDataset.AfterOpen;
    FDataset.AfterOpen:=@DoOnOpen;
    end;
  if FDataset.Active then
    InitFields;
end;

destructor TFieldMap.Destroy;
begin
  if FFreeDataset then
    FreeAndNil(FFreeDataset);
  inherited Destroy;
end;

procedure TFieldMap.LoadObject(AObject: TObject);
begin
  If (AObject=Nil) then
    Raise EFieldMap.CreateFmt(SErrNoObjectToLoad,[ClassName]);
end;

function TFieldMap.FieldByName(FN: String): TField;
begin
  Result:=FDataset.FieldByName(FN)
end;

procedure TFieldMap.DoOnOpen(Sender: TDataset);
begin
  InitFields;
  If Assigned(FOldOnOpen) then
    FOldOnOpen(Sender);
end;

function TFieldMap.FindField(FN: String): TField;
begin
  If (FDataset=Nil) then
    Result:=Nil
  else
    Result:=FDataset.FindField(FN);
end;

function TFieldMap.GetFromField(F: TField; ADefault: Integer): Integer;
begin
  If Assigned(F) then
    Result:=F.AsInteger
  else
    Result:=ADefault;
end;

function TFieldMap.GetFromField(F: TField; ADefault: String): String;
begin
  If Assigned(F) then
    Result:=F.AsString
  else
    Result:=ADefault;
end;

function TFieldMap.GetFromField(F: TField; ADefault: Boolean): Boolean;
begin
  If Assigned(F) then
    begin
    if (F is TStringField) then
      Result:=(F.AsString='+')
    else
      Result:=F.AsBoolean
    end
  else
    Result:=ADefault;
end;

function TFieldMap.GetFromField(F: TField; ADefault: TDateTime): TDateTime;
begin
  If Assigned(F) then
    Result:=F.AsDateTime
  else
    Result:=ADefault;
end;

function TFieldMap.GetFromField(F: TField; ADefault: Currency): Currency;
begin
  If Assigned(F) then
    Result:=F.AsCurrency
  else
    Result:=ADefault;
end;

end.
 
