absedit.pas

Absolute Database 是来替代BDE[Borland数据库引擎]的用于Delphi 和 C++ Builder 开发用的数据库引擎. 它小巧, 高速, 健壮, 易于使用. 它能直接编译进

//==============================================================================
//
//              Property editors
//
//==============================================================================

{$I ABSVer.inc}

unit ABSEdit;

interface

uses
 Classes, Db, Dialogs, Forms, SysUtils,
 ABSFldLinks, ABSMain, ABSConst,
 {$IFDEF DEBUG_LOG}
 ABSDebug,
 {$ENDIF}
 {$IFDEF D6H}
  DesignIntf, DesignEditors, Variants
 {$ELSE}
  DSGNINTF
 {$ENDIF}
 ;

 type

////////////////////////////////////////////////////////////////////////////////
//
// TABSFieldLinkProperty
//
////////////////////////////////////////////////////////////////////////////////


  TABSFieldLinkProperty = class(TABSBaseFieldLinkProperty)
  private
    FTable: TABSTable;
  protected
    procedure GetFieldNamesForIndex(List: TStrings); override;
    function GetIndexBased: Boolean; override;
    function GetIndexDefs: TIndexDefs; override;
    function GetIndexFieldNames: string; override;
    function GetIndexName: string; override;
    function GetMasterFields: string; override;
    procedure SetIndexFieldNames(const Value: string); override;
    procedure SetIndexName(const Value: string); override;
    procedure SetMasterFields(const Value: string); override;
  public
    procedure Edit; override;

    property IndexBased: Boolean read GetIndexBased;
    property IndexDefs: TIndexDefs read GetIndexDefs;
    property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
    property IndexName: string read GetIndexName write SetIndexName;
    property MasterFields: string read GetMasterFields write SetMasterFields;

  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDBStringProperty
//
////////////////////////////////////////////////////////////////////////////////


  TABSDBStringProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValueList(List: TStrings); virtual;
    procedure GetValues(Proc: TGetStrProc); override;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSIndexFieldNamesProperty
//
////////////////////////////////////////////////////////////////////////////////


  // editor for indexFieldNames property
  TABSIndexFieldNamesProperty = class(TABSDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSIndexNameProperty
//
////////////////////////////////////////////////////////////////////////////////


  // editor for indexName property
  TABSIndexNameProperty = class(TABSDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSTableNameProperty
//
////////////////////////////////////////////////////////////////////////////////


  // editor for TableName property
  TABSTableNameProperty = class(TABSDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDatabaseNameProperty
//
////////////////////////////////////////////////////////////////////////////////


  // editor for DatabaseName property
  TABSDatabaseNameProperty = class(TABSDBStringProperty)
  public
    procedure GetValueList(List: TStrings); override;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDatabaseFileNameProperty
//
////////////////////////////////////////////////////////////////////////////////


 // file open dialog - for selecting database file name
 TABSDatabaseFileNameProperty = class (TStringProperty)
   public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
   end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSSessionNameProperty
//
////////////////////////////////////////////////////////////////////////////////


 // TABSSessionNameProperty
 TABSSessionNameProperty = class(TABSDBStringProperty)
   public
      procedure GetValueList(List: TStrings); override;
   end;


function GetPropertyValue(Instance: TPersistent; const PropName: string): TPersistent;


implementation

uses TypInfo;

////////////////////////////////////////////////////////////////////////////////
//
// TABSFieldLinkProperty
//
////////////////////////////////////////////////////////////////////////////////


procedure TABSFieldLinkProperty.GetFieldNamesForIndex(List: TStrings);
var
  i: Integer;
begin
  for i := 0 to FTable.IndexFieldCount - 1 do
    List.Add(FTable.IndexFields[i].FieldName);
end;

function TABSFieldLinkProperty.GetIndexBased: Boolean;
begin
  Result := True;
end;

function TABSFieldLinkProperty.GetIndexDefs: TIndexDefs;
begin
  Result := FTable.IndexDefs;
end;

function TABSFieldLinkProperty.GetIndexFieldNames: string;
begin
  Result := FTable.IndexFieldNames;
end;

function TABSFieldLinkProperty.GetIndexName: string;
begin
  Result := FTable.IndexName;
end;

function TABSFieldLinkProperty.GetMasterFields: string;
begin
  Result := FTable.MasterFields;
end;

procedure TABSFieldLinkProperty.SetIndexFieldNames(const Value: string);
begin
  FTable.IndexFieldNames := Value;
end;

procedure TABSFieldLinkProperty.SetIndexName(const Value: string);
begin
  FTable.IndexName := Value;
end;

procedure TABSFieldLinkProperty.SetMasterFields(const Value: string);
begin
  FTable.MasterFields := Value;
end;

procedure TABSFieldLinkProperty.Edit;
var
  Table:  TABSTable;
  s :     String;
begin
  Table := DataSet as TABSTable;
  FTable := TABSTable.Create(nil);
  try
    FTable.DatabaseName := Table.DatabaseName;
    FTable.SessionName := Table.SessionName;
    FTable.InMemory := Table.InMemory;
    FTable.Temporary := Table.Temporary;
    FTable.TableName := Table.TableName;
    FTable.ReadOnly := Table.ReadOnly;
    FTable.FieldDefs.Assign(Table.FieldDefs);
    FTable.IndexDefs.Assign(Table.IndexDefs);
    FTable.AdvFieldDefs.Assign(Table.AdvFieldDefs);
    FTable.AdvIndexDefs.Assign(Table.AdvIndexDefs);

{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit 0');
{$ENDIF}
    FTable.Open;
{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit 1');
{$ENDIF}
    if (Table.IndexFieldNames <> '') then
     FTable.IndexFieldNames := Table.IndexFieldNames
    else
     FTable.IndexName := Table.IndexName;
    FTable.MasterFields := Table.MasterFields;
{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit 2');
{$ENDIF}
    inherited Edit;
{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit 3');
{$ENDIF}
   if Changed then
    begin
      Table.MasterFields := FTable.MasterFields;
      if FTable.IndexFieldNames <> '' then
       begin
        // index field names
        Table.IndexFieldNames := FTable.IndexFieldNames;
        s := FTable.IndexFieldNames;
       end
      else
       begin
        // index name
        Table.IndexName := FTable.IndexName;
        s := FTable.IndexName;
       end;
    end;
{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit 4');
{$ENDIF}
  finally
    FTable.Free;
  end;
{$IFDEF DEBUG_TRACE_DATASET}
aaWriteToLog('TABSFieldLinkProperty.Edit finish');
{$ENDIF}
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDBStringProperty
//
////////////////////////////////////////////////////////////////////////////////


function TABSDBStringProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList, paSortList, paMultiSelect];
end;

procedure TABSDBStringProperty.GetValueList(List: TStrings);
begin
end;

procedure TABSDBStringProperty.GetValues(Proc: TGetStrProc);
var
  I:      Integer;
  Values: TStringList;
begin
  Values := TStringList.Create;
  try
    GetValueList(Values);
    for I := 0 to Values.Count - 1 do
      Proc(Values[I]);
  finally
    Values.Free;
  end;
end;


function GetIndexDefs(Component: TPersistent): TIndexDefs;
var
  DataSet: TABSTable;
  a : Boolean;
begin
  Result := nil;
  DataSet := Component as TABSTable;
  if (Dataset.Exists) then
    begin
      a := DataSet.Active;
      if (not a) then
       DataSet.Open;
      Result := GetPropertyValue(DataSet, 'IndexDefs') as TIndexDefs;
      if Assigned(Result) then
      begin
        Result.Updated := False;
        Result.Update;
      end;
      if (not a) then
       DataSet.Close;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSIndexFieldNamesProperty
//
////////////////////////////////////////////////////////////////////////////////


procedure TABSIndexFieldNamesProperty.GetValueList(List: TStrings);
var
  I: Integer;
  IndexDefs: TIndexDefs;
begin
  try
    IndexDefs := GetIndexDefs(GetComponent(0));
    if (IndexDefs <> nil) then
      for I := 0 to IndexDefs.Count - 1 do
        with IndexDefs[I] do
          if (Options * [ixExpression, ixDescending] = []) and (Fields <> '') then
            List.Add(Fields);
  except
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSIndexNameProperty
//
////////////////////////////////////////////////////////////////////////////////


procedure TABSIndexNameProperty.GetValueList(List: TStrings);
var
  IndexDefs: TIndexDefs;
begin
  try
    IndexDefs := GetIndexDefs(GetComponent(0));
    if (IndexDefs <> nil) then
      IndexDefs.GetItemNames(List);
  except
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSTableNameProperty
//
////////////////////////////////////////////////////////////////////////////////


procedure TABSTableNameProperty.GetValueList(List: TStrings);
var
  Table: TABSTable;
begin
  Table := TABSTable(GetComponent(0));
  try
    Table.DBSession.GetTableNames(Table.DatabaseName, List);
  except
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDatabaseNameProperty
//
////////////////////////////////////////////////////////////////////////////////


procedure TABSDatabaseNameProperty.GetValueList(List: TStrings);
begin
 TABSDataset(GetComponent(0)).GetDatabaseNameList(List);
end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSDatabaseFileNameProperty
//
////////////////////////////////////////////////////////////////////////////////


//------------------------------------------------------------------------------
// file name editor (extension is subtracted from name)
//------------------------------------------------------------------------------
procedure TABSDatabaseFileNameProperty.Edit;
var
  td : TOpenDialog;
begin
 td := TOpenDialog.Create(Application);
 td.Options := [ofFileMustExist];
 td.Filter := 'Absolute Database (*'+ABSDatabaseFileExtension+')|*'+ABSDatabaseFileExtension;
 if (td.Execute) then
   SetStrValue(td.FileName);
 td.Free;
end; // Edit


//------------------------------------------------------------------------------
// file name editor's attributes (paDialog - for ... button in design mode)
//------------------------------------------------------------------------------
function TABSDatabaseFileNameProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paRevertable];
end; // GetAttributes




////////////////////////////////////////////////////////////////////////////////
//
// TABSSessionNameProperty
//
////////////////////////////////////////////////////////////////////////////////


//------------------------------------------------------------------------------
//  TABSSession names
//------------------------------------------------------------------------------
procedure TABSSessionNameProperty.GetValueList(List: TStrings);
begin
  Sessions.GetSessionNames(List);
end;

{ Utility Functions }

function GetPropertyValue(Instance: TPersistent; const PropName: string): TPersistent;
var
  PropInfo: PPropInfo;
begin
  Result := nil;
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
    Result := TObject(GetOrdProp(Instance, PropInfo)) as TPersistent;
end;


end.