ibtable.pas

这是不可多得的源代码

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2001 Borland Software Corporation             }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You may obtain }
{    a copy of the License at http://www.borland.com/interbase/IPL.html  }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Borland Software Corporation are Copyright      }
{       (C) Borland Software Corporation. All Rights Reserved.           }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{************************************************************************}

unit IBTable;

interface

uses SysUtils, Classes, DB, IB, IBDatabase, IBCustomDataSet,
     IBHeader, IBSQL, IBUtils;
     
type

{ TIBTable }

  TIBTableType = (ttSystem, ttView);
  TIBTableTypes = set of TIBTableType;
  TIndexName = String;

  TIBTable = class;

  TIBTable = class(TIBCustomDataSet)
  private
    FSystemTable: Boolean;
    FMultiTableView: Boolean;
    FMasterLink: TMasterDataLink;
    FMasterFieldsList: TStringList;
    FDetailFieldsList: TStringList;
    FStoreDefs: Boolean;
    FIndexDefs: TIndexDefs;
    FDefaultIndex: Boolean;
    FReadOnly: Boolean;
    FFieldsIndex: Boolean;
    FTableName: String;
    FIndexName: TIndexName;
    FRegenerateSQL: Boolean;
    FNameList: TStrings;
    FSwitchingIndex: Boolean;
    FPrimaryIndexFields: string;
    FTableTypes: TIBTableTypes;
    WhereAllRefreshSQL: TStrings;
    WhereDBKeyRefreshSQL: TStrings;
    WherePrimaryRefreshSQL: TStrings;

    function GetIndexFieldCount: Integer;
    function GetIndexField(Index: Integer): TField;
    procedure MasterChanged(Sender: TObject);
    procedure MasterDisabled(Sender: TObject);
    procedure SetDataSource(Value: TDataSource);
    procedure SetIndexField(Index: Integer; Value: TField);
    procedure SetIndexFieldNames(const Value: string);
    procedure GenerateSQL;
    procedure GenerateUpdateSQL;
    procedure SwitchToIndex();
    procedure InternalTableRefresh();
    function GetTableNames: TStrings;
    procedure GetTableNamesFromServer;
    procedure SetTableTypes(const Value: TIBTableTypes);
    function InternalGotoDBKey(DBKey: TIBDBKey): Boolean;
    function FormatFieldsList(Value: string): string;
    function GetCurrentDBKey: TIBDBKey;
    function InternalGetUpdatable: Boolean;
    function GetExists: Boolean;
    procedure SetIndexDefs(Value: TIndexDefs);
    procedure ExtractLinkFields;
    function FieldDefsStored: Boolean;
    function IndexDefsStored: Boolean;
    function GetMasterFields: string;
    procedure SetMasterFields(const Value: string);
    function GetIndexFieldNames: string;
    function GetIndexName: string;
    procedure SetIndexName(const Value: string);
    procedure SetParams;
    procedure SetReadOnly(Value: Boolean);
    procedure SetTableName(Value: String);
    procedure SetIndex(const Value: string; FieldsIndex: Boolean);
    procedure ResetSQLStatements;
    procedure Reopen;
    function InternalLocate(const KeyFields: string; const KeyValues: Variant;
                            Options: TLocateOptions): Boolean;
  protected
    { IProviderSupport }
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetKeyFields: string; override;
    function PSGetTableName: string; override;
    function PSGetIndexDefs(IndexTypes: TIndexOptions): TIndexDefs; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;

    procedure DoOnNewRecord; override;
    procedure GetIndexParams(const IndexName: string; FieldsIndex: Boolean;
      var IndexedName: string);
    function GetCanModify: Boolean; override;
    procedure UpdateIndexDefs; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DefChanged(Sender: TObject); override;
    function GetDataSource: TDataSource; override;
    procedure InitFieldDefs; override;
    procedure InternalClose; override;
    procedure InternalOpen; override;
    procedure InternalRefresh; override;
    procedure SetFiltered(Value: Boolean); override;
    procedure SetFilterText(const Value: string); override;
    procedure SetFilterOptions(Value: TFilterOptions); override;
    procedure InternalRefreshRow; override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddIndex(const Name, Fields: string; Options: TIndexOptions;
      const DescFields: string = '');
    procedure CreateTable;
    procedure DeleteIndex(const Name: string);
    procedure DeleteTable;
    procedure EmptyTable;
    procedure GetDetailLinkFields(MasterFields, DetailFields: TList); override;
    procedure GetIndexNames(List: TStrings);
    procedure GotoCurrent(Table: TIBTable);
    function Locate(const KeyFields: string; const KeyValues: Variant;
                    Options: TLocateOptions): Boolean; override;

    property LiveMode;
    property CurrentDBKey: TIBDBKey read GetCurrentDBKey;
    property Exists: Boolean read GetExists;
    property IndexFieldCount: Integer read GetIndexFieldCount;
    property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
    property TableNames: TStrings read GetTableNames;

  published
    property Active;
    property BufferChunks;
    property CachedUpdates;
    property Constraints stored ConstraintsStored;
    property DefaultIndex: Boolean read FDefaultIndex write FDefaultIndex default True;
    property FieldDefs stored FieldDefsStored;
    property Filter;
    property Filtered;
    property IndexDefs: TIndexDefs read FIndexDefs write SetIndexDefs stored IndexDefsStored;
    property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
    property IndexName: string read GetIndexName write SetIndexName;
    property MasterFields: string read GetMasterFields write SetMasterFields;
    property MasterSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;
    property TableName: String read FTableName write SetTableName;
    property TableTypes: TIBTableTypes read FTableTypes write SetTableTypes default [];
    property UpdateObject;
    property UniDirectional;

    property BeforeDatabaseDisconnect;
    property AfterDatabaseDisconnect;
    property DatabaseFree;
    property BeforeTransactionEnd;
    property AfterTransactionEnd;
    property TransactionFree;
    property OnFilterRecord;
  end;

implementation

uses Variants;

{ TIBTable }

constructor TIBTable.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FNameList := TStringList.Create;
  FSwitchingIndex := False;
  FIndexDefs := TIndexDefs.Create(Self);
  WhereAllRefreshSQL := TStringList.Create;
  WhereDBKeyRefreshSQL := TStringList.Create;
  WherePrimaryRefreshSQL := TStringList.Create;
  FDefaultIndex := True;
  FRegenerateSQL := True;
  FMasterFieldsList := TStringList.Create;
  FDetailFieldsList := TStringList.Create;
  FMasterLink := TMasterDataLink.Create(Self);
  FMasterLink.OnMasterChange := MasterChanged;
  FMasterLink.OnMasterDisable := MasterDisabled;
  QRefresh.OnSQLChanging := nil;
  QDelete.OnSQLChanging := nil;
  QInsert.OnSQLChanging := nil;
  QModify.OnSQLChanging := nil;
end;

destructor TIBTable.Destroy;
begin
  FNameList.Free;
  FIndexDefs.Free;
  FMasterFieldsList.Free;
  FDetailFieldsList.Free;
  FMasterLink.Free;
  WhereAllRefreshSQL.Free;
  WhereDBKeyRefreshSQL.Free;
  WherePrimaryRefreshSQL.Free;
  inherited Destroy;
end;

procedure TIBTable.InternalClose;
begin
  DataEvent(dePropertyChange, 0);
  inherited InternalClose;
end;

procedure TIBTable.InternalOpen;
begin
  if FTableName = '' then
    IBError(ibxeNoTableName, [nil]);
  ActivateConnection;
  ActivateTransaction;
  if FRegenerateSQL then
  begin
    InternalUnprepare;
    GenerateSQL;
    FRegenerateSQL := False;
  end;
  SetParams;
  inherited InternalOpen;
end;

procedure TIBTable.InternalRefresh;
var
  DBKey: TIBDBKey;
begin
  DBKey := CurrentDBKey;
  Reopen;
  if DBKey.DBKey[0] <> 0 then
    InternalGotoDBKey(DBKey);
end;

procedure TIBTable.SetFiltered(Value: Boolean);
begin
  if(Filtered <> Value) then
  begin
    inherited SetFiltered(value);
    if Active then
      InternalTableRefresh;
  end
  else
    inherited SetFiltered(value);
end;

procedure TIBTable.SetFilterText(const Value: string);
begin
  if Filtered and (Value <> Filter) then
  begin
    inherited SetFilterText(value);
    InternalTableRefresh;
  end
  else
    inherited SetFilterText(value);
end;

procedure TIBTable.SetFilterOptions(Value: TFilterOptions);
begin
  if Value <> [] then
    IBError(ibxeNotSupported, [nil]);
end;

procedure TIBTable.InternalRefreshRow;
begin
  if CurrentDBKey.DBKey[0] <> 0 then
    QRefresh.SQL.Assign(WhereDBKeyRefreshSQL)
  else if WherePrimaryRefreshSQL.Text <> '' then
    QRefresh.SQL.Assign(WherePrimaryRefreshSQL)
  else
    QRefresh.SQL.Assign(WhereAllRefreshSQL);
  inherited InternalRefreshRow;
end;

procedure TIBTable.DefChanged(Sender: TObject);
begin
  StoreDefs := True;
end;

procedure TIBTable.InitFieldDefs;
var
  sqlscale: Integer;
  Query: TIBSQL;
begin
  if FTableName = '' then IBError(ibxeNoTableName, [nil]);
  if (InternalPrepared) then InternalInitFieldDefs else
  begin
    Database.InternalTransaction.StartTransaction;
    Query := TIBSQL.Create(self);
    try
      Query.GoToFirstRecordOnExecute := False;
      Query.Database := DataBase;
      Query.Transaction := Database.InternalTransaction;
      Query.SQL.Text := 'Select R.RDB$FIELD_NAME, R.RDB$FIELD_POSITION, ' + {do not localize}
                        'F.RDB$COMPUTED_BLR, F.RDB$DEFAULT_VALUE, ' + {do not localize}
                        'F.RDB$NULL_FLAG, ' + {do not localize}
                        'F.RDB$FIELD_LENGTH, F.RDB$FIELD_SCALE, ' + {do not localize}
                        'F.RDB$FIELD_TYPE, F.RDB$FIELD_SUB_TYPE, ' + {do not localize}
                        'F.RDB$EXTERNAL_LENGTH, F.RDB$EXTERNAL_SCALE, F.RDB$EXTERNAL_TYPE ' + {do not localize}
                        'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
                        'where R.RDB$RELATION_NAME = ' + {do not localize}
                        '''' +
                        FormatIdentifierValue(Database.SQLDialect,
                          QuoteIdentifier(DataBase.SQLDialect, FTableName)) +
                        ''' ' +
                        'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
                        'order by R.RDB$FIELD_POSITION'; {do not localize}

      Query.Prepare;
      Query.ExecQuery;
      FieldDefs.BeginUpdate;
      FieldDefs.Clear;
      while (not Query.EOF) and (Query.Next <> nil) do
      begin
          with FieldDefs.AddFieldDef do
          begin
            FieldNo := Query.Current.ByName('RDB$FIELD_POSITION').AsInteger; {do not localize}
            Name := TrimRight(Query.Current.ByName('RDB$FIELD_NAME').AsString); {do not localize}
            case Query.Current.ByName('RDB$FIELD_TYPE').AsInteger of {do not localize}
              blr_varying, blr_text:
              begin
                DataType := ftString;
                Size := Query.Current.ByName('RDB$FIELD_LENGTH').AsInteger; {do not localize}
              end;
              blr_float, blr_double, blr_d_float: DataType := ftFloat;
              blr_short:
              begin
                sqlscale := Query.Current.ByName('RDB$FIELD_SCALE').AsInteger; {do not localize}
                if (sqlscale = 0) then
                  DataType := ftSmallInt
                else
                begin
                  DataType := ftBCD;
                  Precision := 4;
                  Size := -sqlscale;
                end;
              end;
              blr_long:
              begin
                sqlscale := Query.Current.ByName('RDB$FIELD_SCALE').AsInteger; {do not localize}
                if (sqlscale = 0) then
                  DataType := ftInteger
                else if (sqlscale >= (-4)) then
                begin
                  DataType := ftBCD;
                  Precision := 9;
                  Size := -sqlscale;
                end
                else
                  DataType := ftFloat;
              end;
              blr_int64:
              begin
                sqlscale := Query.Current.ByName('RDB$FIELD_SCALE').AsInteger; {do not localize}
                if (sqlscale = 0) then
                  DataType := ftLargeInt
                else if (sqlscale >= (-4)) then
                begin
                  DataType := ftBCD;
                  Precision := 18;
                  Size := -sqlscale;
                end
                else
                  DataType := ftFloat;
              end;
              blr_timestamp: DataType := ftDateTime;
              blr_sql_time: DataType := ftTime;
              blr_sql_date: DataType := ftDate;
              blr_blob:
                if (Query.Current.ByName('RDB$FIELD_SUB_TYPE').AsInteger = 1) then {do not localize}
                  DataType := ftMemo
                else
                  DataType := ftBlob;
              blr_quad:
              begin
                DataType := ftUnknown;
                Size := sizeof (TISC_QUAD);
              end;
              else
                DataType := ftUnknown;
            end;
            if not (Query.Current.ByName('RDB$COMPUTED_BLR').IsNull) then {do not localize}
            begin
              Attributes := [faReadOnly];
              InternalCalcField := True
            end
            else
              InternalCalcField := False;
            if ((not InternalCalcField) and
                 Query.Current.ByName('RDB$DEFAULT_VALUE').IsNull and {do not localize}
                 (Query.Current.ByName('RDB$NULL_FLAG').AsInteger = 1) )then {do not localize}
            begin
              Attributes := [faRequired];
              Required := True;
            end;
          end;
      end;
      FieldDefs.EndUpdate;
    finally
      Query.free;
      Database.InternalTransaction.Commit;
    end;
  end;
end;

{ Index / Ranges / Keys }

procedure TIBTable.AddIndex(const Name, Fields: string; Options: TIndexOptions;
  const DescFields: string);
var
  Query: TIBSQL;
  FieldList: string;
begin
  FieldDefs.Update;
  if Active then begin
    CheckBrowseMode;