jvquibmetadata.pas

East make Tray Icon in delphi

    function GetOutputFieldsCount: Integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure InternalSaveToDDL(Stream: TStringStream; Operation: string);
    procedure SaveToPostDDL(Stream: TStringStream);
  public
    procedure SaveToDDLNode(Stream: TStringStream); override;
    class function NodeClass: string; override;
    class function NodeType: TMetaNodeType; override;
    constructor Create(AOwner: TMetaNode; ClassIndex: Integer); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure SaveToAlterDDL(Stream: TStringStream);

    property Source: string read FSource;

    property InputFields[const Index: Integer]: TMetaProcInField read GetInputFields;
    property InputFieldsCount: Integer read GetInputFieldsCount;

    property OutputFields[const Index: Integer]: TMetaProcOutField read GetOutputFields;
    property OutputFieldsCount: Integer read GetOutputFieldsCount;
  end;

  TMetaException = class(TMetaNode)
  private
    FMessage: string;
    FNumber: Integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromQuery(QName: TJvUIBStatement);
  public
    procedure SaveToDDLNode(Stream: TStringStream); override;
    class function NodeClass: string; override;
    class function NodeType: TMetaNodeType; override;
    procedure SaveToStream(Stream: TStream); override;
    property Message: string read FMessage;
    property Number: Integer read FNumber;
  end;

  TMetaUDFField = class(TMetaBaseField)
  private
    FPosition: Smallint;
    FMechanism: Smallint;
    procedure LoadFromQuery(QField, QCharset: TJvUIBStatement); override;
    procedure LoadFromStream(Stream: TStream); override;
  public
    class function NodeType: TMetaNodeType; override;
    procedure SaveToDDLNode(Stream: TStringStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Position: Smallint read FPosition;
    property Mechanism: Smallint read FMechanism;
  end;

  TMetaUDF = class(TMetaNode)
  private
    FModule: string;
    FEntry: string;
    FReturn: Smallint;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromQuery(QNames, QFields, QCharset: TJvUIBStatement; OIDs: TOIDUDFs);
    function GetFields(const Index: Integer): TMetaUDFField;
    function GetFieldsCount: Integer;
  public
    procedure SaveToDDLNode(Stream: TStringStream); override;
    class function NodeClass: string; override;
    class function NodeType: TMetaNodeType; override;
    constructor Create(AOwner: TMetaNode; ClassIndex: Integer); override;
    procedure SaveToStream(Stream: TStream); override;
    property Module: string read FModule;
    property Entry: string read FEntry;
    property Return: Smallint read FReturn;
    property Fields[const Index: Integer]: TMetaUDFField read GetFields;
    property FieldsCount: Integer read GetFieldsCount;
  end;

  TMetaRole = class(TMetaNode)
  private
    FOwner: string;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromQuery(QName: TJvUIBStatement);
  public
    procedure SaveToDDLNode(Stream: TStringStream); override;
    class function NodeClass: string; override;
    class function NodeType: TMetaNodeType; override;
    procedure SaveToStream(Stream: TStream); override;
    property Owner: string read FOwner;
  end;

  TMetaDataBase = class(TMetaNode)
  private
    FOIDDatabases: TOIDDatabases;
    FOIDTables: TOIDTables;
    FOIDViews: TOIDViews;
    FOIDProcedures: TOIDProcedures;
    FOIDUDFs: TOIDUDFs;
    FSysInfos: Boolean;
    function GetGenerators(const Index: Integer): TMetaGenerator;
    function GetGeneratorsCount: Integer;

    function GetTables(const Index: Integer): TMetaTable;
    function GetTablesCount: Integer;
    function FindTableIndex(const TableName: string): Integer;
    function FindDomainIndex(const DomainName: string): Integer;
    function GetViews(const Index: Integer): TMetaView;
    function GetViewsCount: Integer;
    function GetDomains(const Index: Integer): TMetaDomain;
    function GetDomainsCount: Integer;

    procedure LoadFromStream(Stream: TStream); override;
    function GetProcedures(const Index: Integer): TMetaProcedure;
    function GetProceduresCount: Integer;
    function GetExceptions(const Index: Integer): TMetaException;
    function GetExceptionsCount: Integer;
    function GetUDFS(const Index: Integer): TMetaUDF;
    function GetUDFSCount: Integer;
    function GetRoles(const Index: Integer): TMetaRole;
    function GetRolesCount: Integer;
  public
    class function NodeClass: string; override;
    class function NodeType: TMetaNodeType; override;
    procedure SaveToStream(Stream: TStream); override;
    function FindTableName(const TableName: string): TMetaTable;
    function FindProcName(const ProcName: string): TMetaProcedure;
    constructor Create(AOwner: TMetaNode; ClassIndex: Integer); override;
    procedure LoadFromDatabase(Transaction: TJvUIBTransaction);
    procedure SaveToDDL(Stream: TStringStream); override;

    property OIDDatabases: TOIDDatabases read FOIDDatabases write FOIDDatabases;

    property Generators[const Index: Integer]: TMetaGenerator read GetGenerators;
    property GeneratorsCount: Integer read GetGeneratorsCount;

    property Tables[const Index: Integer]: TMetaTable read GetTables;
    property TablesCount: Integer read GetTablesCount;
    property OIDTables: TOIDTables read FOIDTables write FOIDTables;

    property Views[const Index: Integer]: TMetaView read GetViews;
    property ViewsCount: Integer read GetViewsCount;
    property OIDViews: TOIDViews read FOIDViews write FOIDViews;

    property Domains[const Index: Integer]: TMetaDomain read GetDomains;
    property DomainsCount: Integer read GetDomainsCount;

    property Procedures[const Index: Integer]: TMetaProcedure read GetProcedures;
    property ProceduresCount: Integer read GetProceduresCount;
    property OIDProcedures: TOIDProcedures read FOIDProcedures write FOIDProcedures;

    property Exceptions[const Index: Integer]: TMetaException read GetExceptions;
    property ExceptionsCount: Integer read GetExceptionsCount;

    property UDFS[const Index: Integer]: TMetaUDF read GetUDFS;
    property UDFSCount: Integer read GetUDFSCount;
    property OIDUDFs: TOIDUDFs read FOIDUDFs write FOIDUDFs;

    property Roles[const Index: Integer]: TMetaRole read GetRoles;
    property RolesCount: Integer read GetRolesCount;

    property SysInfos: Boolean read FSysInfos write FSysInfos;
  end;

implementation


{$IFDEF UNITVERSIONING}
uses
  JclUnitVersioning;
{$ENDIF UNITVERSIONING}


//   Database Tree
//------------------------
//  OIDDomains   = 0;
//  OIDTable     = 1;
//    OIDTableFields   = 0;
//    OIDPrimary       = 1;
//    OIDForeign       = 2;
//    OIDTableTrigger  = 3;
//    OIDUnique        = 4;
//    OIDIndex         = 5;
//    OIDCheck         = 6;
//  OIDView      = 2;
//    OIDViewFields    = 0;
//    OIDViewTrigers   = 1;
//  OIDProcedure = 3;
//    OIDProcFieldIn   = 0;
//    OIDProcFieldOut  = 1;
//  OIDGenerator = 4;
//  OIDException = 5;
//  OIDUDF       = 6;
//    OIDUDFField      = 0;
//  OIDRole      = 7;

const
  TriggerPrefixTypes: array [TTriggerPrefix] of PChar =
    ('BEFORE', 'AFTER');

  TriggerSuffixTypes: array [TTriggerSuffix] of PChar =
    ('INSERT', 'UPDATE', 'DELETE');

  FieldTypes: array [TUIBFieldType] of PChar =
   ('', 'NUMERIC', 'CHAR', 'VARCHAR', 'CSTRING', 'SMALLINT', 'INTEGER', 'QUAD',
    'FLOAT', 'DOUBLE PRECISION', 'TIMESTAMP', 'BLOB', 'BLOBID', 'DATE', 'TIME',
    'INT64' {$IFDEF IB7_UP}, 'BOOLEAN' {$ENDIF});

  QRYGenerators =
    'SELECT RDB$GENERATOR_NAME FROM RDB$GENERATORS GEN WHERE ' +
    '(NOT GEN.RDB$GENERATOR_NAME STARTING WITH ''RDB$'') AND ' +
    '(NOT GEN.RDB$GENERATOR_NAME STARTING WITH ''SQL$'') AND ' +
    '((GEN.RDB$SYSTEM_FLAG IS NULL) OR (GEN.RDB$SYSTEM_FLAG <> 1)) ' +
    'ORDER BY GEN.RDB$GENERATOR_NAME';

  QRYTables =
    'SELECT REL.RDB$RELATION_NAME FROM RDB$RELATIONS REL WHERE ' +
    '(REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
    '(NOT REL.RDB$FLAGS IS NULL) AND ' +
    '(REL.RDB$VIEW_BLR IS NULL) AND ' +
    '(REL.RDB$SECURITY_CLASS STARTING WITH ''SQL$'') ' +
    'ORDER BY REL.RDB$RELATION_NAME';

  QRYSysTables =
    'SELECT REL.RDB$RELATION_NAME FROM RDB$RELATIONS REL ' +
    'WHERE REL.RDB$VIEW_BLR IS NULL ORDER BY REL.RDB$RELATION_NAME';

  QRYTableFields =
    'SELECT FLD.RDB$FIELD_TYPE, FLD.RDB$FIELD_SCALE, ' +
    'FLD.RDB$FIELD_LENGTH, FLD.RDB$FIELD_PRECISION, ' +
    'FLD.RDB$CHARACTER_SET_ID, FLD.RDB$FIELD_SUB_TYPE, RFR.RDB$FIELD_NAME, ' +
    'FLD.RDB$SEGMENT_LENGTH, RFR.RDB$NULL_FLAG, RFR.RDB$DEFAULT_SOURCE, ' +
    'RFR.RDB$FIELD_SOURCE , FLD.RDB$COMPUTED_SOURCE ' +
    'FROM RDB$RELATIONS REL, RDB$RELATION_FIELDS RFR, RDB$FIELDS FLD ' +
    'WHERE (RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME) AND ' +
    '(RFR.RDB$RELATION_NAME = REL.RDB$RELATION_NAME) AND ' +
    '(REL.RDB$RELATION_NAME = ?) ' +
    'ORDER BY RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME';

  QRYCharset =
    'SELECT RDB$CHARACTER_SET_ID, RDB$CHARACTER_SET_NAME, RDB$BYTES_PER_CHARACTER FROM RDB$CHARACTER_SETS';

  QRYUnique =
    'SELECT RC.RDB$CONSTRAINT_NAME, IDX.RDB$FIELD_NAME ' +
    'FROM RDB$RELATION_CONSTRAINTS RC, RDB$INDEX_SEGMENTS IDX ' +
    'WHERE (IDX.RDB$INDEX_NAME = RC.RDB$INDEX_NAME) AND ' +
    '(RC.RDB$CONSTRAINT_TYPE = ?) ' +
    'AND (RC.RDB$RELATION_NAME = ?) ' +
    'ORDER BY RC.RDB$RELATION_NAME, IDX.RDB$FIELD_POSITION';

  QRYIndex =
    'SELECT IDX.RDB$INDEX_NAME, ISG.RDB$FIELD_NAME, IDX.RDB$UNIQUE_FLAG, ' +
    'IDX.RDB$INDEX_INACTIVE, IDX.RDB$INDEX_TYPE FROM RDB$INDICES IDX ' +
    'LEFT JOIN RDB$INDEX_SEGMENTS ISG ON ISG.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME ' +
    'LEFT JOIN RDB$RELATION_CONSTRAINTS C ON IDX.RDB$INDEX_NAME = C.RDB$INDEX_NAME ' +
    'WHERE (C.RDB$CONSTRAINT_NAME IS NULL) AND (IDX.RDB$RELATION_NAME = ?) ' +
    'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, ISG.RDB$FIELD_POSITION';

  QRYForeign =
    'SELECT A.RDB$CONSTRAINT_NAME, B.RDB$UPDATE_RULE, B.RDB$DELETE_RULE, ' +
    'C.RDB$RELATION_NAME AS FK_TABLE, D.RDB$FIELD_NAME AS FK_FIELD, ' +
    'E.RDB$FIELD_NAME AS ONFIELD ' +
    'FROM RDB$REF_CONSTRAINTS B, RDB$RELATION_CONSTRAINTS A, RDB$RELATION_CONSTRAINTS C, ' +
    'RDB$INDEX_SEGMENTS D, RDB$INDEX_SEGMENTS E ' +
    'WHERE (A.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'') AND ' +
    '(A.RDB$CONSTRAINT_NAME = B.RDB$CONSTRAINT_NAME) AND ' +
    '(B.RDB$CONST_NAME_UQ=C.RDB$CONSTRAINT_NAME) AND (C.RDB$INDEX_NAME=D.RDB$INDEX_NAME) AND ' +
    '(A.RDB$INDEX_NAME=E.RDB$INDEX_NAME) AND ' +
    '(D.RDB$FIELD_POSITION = E.RDB$FIELD_POSITION) ' +
    'AND (A.RDB$RELATION_NAME = ?) ' +
    'ORDER BY A.RDB$CONSTRAINT_NAME, A.RDB$RELATION_NAME, D.RDB$FIELD_POSITION, E.RDB$FIELD_POSITION';

  QRYCheck =
    'SELECT A.RDB$CONSTRAINT_NAME, C.RDB$TRIGGER_SOURCE ' +
    'FROM RDB$RELATION_CONSTRAINTS A, RDB$CHECK_CONSTRAINTS B, RDB$TRIGGERS C ' +
    'WHERE (A.RDB$CONSTRAINT_TYPE = ''CHECK'') AND ' +
    '(A.RDB$CONSTRAINT_NAME = B.RDB$CONSTRAINT_NAME) AND ' +
    '(B.RDB$TRIGGER_NAME = C.RDB$TRIGGER_NAME) AND ' +
    '(C.RDB$TRIGGER_TYPE = 1) ' +
    'AND (A.RDB$RELATION_NAME = ?)';

  QRYTrigger =
    'SELECT T.RDB$TRIGGER_NAME, T.RDB$TRIGGER_SOURCE, T.RDB$TRIGGER_SEQUENCE, ' +
    'T.RDB$TRIGGER_TYPE, T.RDB$TRIGGER_INACTIVE, T.RDB$SYSTEM_FLAG ' +
    'from RDB$TRIGGERS T left join RDB$CHECK_CONSTRAINTS C ON C.RDB$TRIGGER_NAME = ' +
    'T.RDB$TRIGGER_NAME where ((T.RDB$SYSTEM_FLAG = 0) or (T.RDB$SYSTEM_FLAG is null)) ' +
    'and (c.rdb$trigger_name is null) and (T.RDB$RELATION_NAME = ?) ' +
    'order by T.RDB$TRIGGER_NAME';

  QRYSysTrigger =
    'SELECT T.RDB$TRIGGER_NAME, T.RDB$TRIGGER_SOURCE, T.RDB$TRIGGER_SEQUENCE, ' +
    'T.RDB$TRIGGER_TYPE, T.RDB$TRIGGER_INACTIVE, T.RDB$SYSTEM_FLAG ' +
    'FROM RDB$TRIGGERS T LEFT JOIN RDB$CHECK_CONSTRAINTS C ON C.RDB$TRIGGER_NAME = ' +
    'T.RDB$TRIGGER_NAME WHERE (T.RDB$RELATION_NAME = ?) ORDER BY T.RDB$TRIGGER_NAME';

  QRYView =
    'SELECT REL.RDB$RELATION_NAME, REL.RDB$VIEW_SOURCE FROM RDB$RELATIONS REL WHERE ' +
    '(REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
    '(NOT REL.RDB$FLAGS IS NULL) AND ' +
    '(NOT REL.RDB$VIEW_BLR IS NULL) AND ' +
    '(REL.RDB$SECURITY_CLASS STARTING WITH ''SQL$'') ' +
    'ORDER BY REL.RDB$RELATION_NAME';

  QRYDomains =
    'select RDB$FIELD_TYPE, RDB$FIELD_SCALE, RDB$FIELD_LENGTH, ' +
    'RDB$FIELD_PRECISION, RDB$CHARACTER_SET_ID, RDB$FIELD_SUB_TYPE, ' +
    'RDB$FIELD_NAME, RDB$SEGMENT_LENGTH, RDB$NULL_FLAG, RDB$DEFAULT_SOURCE, RDB$COMPUTED_SOURCE ' +
    'FROM RDB$FIELDS WHERE NOT (RDB$FIELD_NAME STARTING WITH ''RDB$'')';

  QRYSysDomains =
    'select RDB$FIELD_TYPE, RDB$FIELD_SCALE, RDB$FIELD_LENGTH, ' +
    'RDB$FIELD_PRECISION, RDB$CHARACTER_SET_ID, RDB$FIELD_SUB_TYPE, ' +
    'RDB$FIELD_NAME, RDB$SEGMENT_LENGTH, RDB$NULL_FLAG, RDB$DEFAULT_SOURCE, RDB$COMPUTED_SOURCE ' +
    'from RDB$FIELDS';

  QRYProcedures =
    'SELECT RDB$PROCEDURE_NAME, RDB$PROCEDURE_SOURCE FROM  RDB$PROCEDURES ORDER BY RDB$PROCEDURE_NAME';

  QRYProcFields =
    'SELECT FS.RDB$FIELD_TYPE, FS.RDB$FIELD_SCALE, FS.RDB$FIELD_LENGTH, FS.RDB$FIELD_PRECISION, ' +
    'FS.RDB$CHARACTER_SET_ID, FS.RDB$FIELD_SUB_TYPE, PP.RDB$PARAMETER_NAME, FS.RDB$SEGMENT_LENGTH ' +
    'FROM RDB$PROCEDURES PR LEFT JOIN RDB$PROCEDURE_PARAMETERS PP ' +
    'ON PP.RDB$PROCEDURE_NAME = PR.RDB$PROCEDURE_NAME LEFT JOIN RDB$FIELDS FS ON ' +
    'FS.RDB$FIELD_NAME = PP.RDB$FIELD_SOURCE LEFT JOIN RDB$CHARACTER_SETS CR ON ' +
    'FS.RDB$CHARACTER_SET_ID = CR.RDB$CHARACTER_SET_ID LEFT JOIN RDB$COLLATIONS CO ' +
    'ON ((FS.RDB$COLLATION_ID = CO.RDB$COLLATION_ID) AND (FS.RDB$CHARACTER_SET_ID = ' +
    'CO.RDB$CHARACTER_SET_ID)) WHERE (PR.RDB$PROCEDURE_NAME = ?) AND ' +
    '(PP.RDB$PARAMETER_TYPE = ?) ORDER BY PP.RDB$PARAMETER_TYPE, PP.RDB$PARAMETER_NUMBER';

  QRYExceptions =
    'SELECT RDB$EXCEPTION_NAME, RDB$MESSAGE, RDB$EXCEPTION_NUMBER FROM RDB$EXCEPTIONS ORDER BY RDB$EXCEPTION_NAME';

  QRYUDF =
    'SELECT RDB$FUNCTION_NAME, RDB$MODULE_NAME, RDB$ENTRYPOINT, RDB$RETURN_ARGUMENT ' +
    'FROM RDB$FUNCTIONS WHERE (RDB$SYSTEM_FLAG IS NULL) ORDER BY RDB$FUNCTION_NAME';

  QRYUDFFields =
    'SELECT RDB$FIELD_TYPE, RDB$FIELD_SCALE, RDB$FIELD_LENGTH, RDB$FIELD_PRECISION, ' +
    'RDB$CHARACTER_SET_ID, RDB$FIELD_SUB_TYPE, RDB$ARGUMENT_POSITION, RDB$MECHANISM ' +
    'FROM RDB$FUNCTION_ARGUMENTS WHERE RDB$FUNCTION_NAME = ? ' +
    'ORDER BY RDB$ARGUMENT_POSITION';

  QRYRoles =
    'SELECT RDB$ROLE_NAME, RDB$OWNER_NAME FROM RDB$ROLES';

procedure WriteString(Stream: TStream; var Str: string);
var
  Len: Integer;
begin
  Len := Length(Str);
  Stream.Write(Len, SizeOf(Len));
  if Len > 0 then
    Stream.Write(PChar(Str)^, Len);
end;

procedure ReadString(Stream: TStream; var Str: string);
var
  Len: Integer;
begin
  Stream.Read(Len, SizeOf(Len));
  SetLength(Str, Len);
  if Len > 0 then
    Stream.Read(PChar(Str)^, Len);
end;

//=== { TMetaNode } ==========================================================

constructor TMetaNode.Create(AOwner: TMetaNode; ClassIndex: Integer);
begin
  // (rom) added inherited Create
  inherited Create;
  FNodeItemsCount := 0;
  FOwner := AOwner;
  if (FOwner <> nil) and (ClassIndex >= 0) then
    FOwner.FNodeItems[ClassIndex].Childs.Add(Self)
end;

constructor TMetaNode.CreateFromStream(AOwner: TMetaNode; ClassIndex: Integer; Stream: TStream);
var
  I, J: Integer;
begin
  Create(AOwner, ClassIndex);
  LoadFromStream(Stream);
  for J := 0 to FNodeItemsCount - 1 do
  begin
    Stream.Read(I, SizeOf(I));
    for I := 0 to I - 1 do
      FNodeItems[J].ClassID.CreateFromStream(Self, J, Stream);
  end;
end;

destructor TMetaNode.Destroy;
var
  I, J: Integer;
begin
  for I := 0 to FNodeItemsCount - 1 do
  begin
    for J := 0 to FNodeItems[I].Childs.Count - 1 do
      TObJect(FNodeItems[I].Childs[J]).Free;
    FNodeItems[I].Childs.Free;
  end;
  inherited Destroy;
end;

function TMetaNode.GetAsDDL: string;
var
  Stream: TStringStream;
begin