Comparison: add support for missing/modified exceptions

comparison.lfm

@@ -15,17 +15,17 @@ object fmComparison: TfmComparison
   LCLVersion = '1.2.2.0'
   object Label1: TLabel
     Left = 15
-    Height = 17
+    Height = 13
     Top = 112
-    Width = 174
+    Width = 125
     Caption = 'Original (target) database'
     ParentColor = False
   end
   object laDatabase: TLabel
     Left = 226
-    Height = 17
+    Height = 13
     Top = 112
-    Width = 80
+    Width = 64
     Caption = 'laDatabase'
     Font.Style = [fsBold]
     ParentColor = False
@@ -33,19 +33,19 @@ object fmComparison: TfmComparison
   end
   object Label2: TLabel
     Left = 16
-    Height = 17
+    Height = 13
     Top = 143
-    Width = 195
+    Width = 140
     Caption = 'Compared (source) database'
     ParentColor = False
   end
   object cbComparedDatabase: TComboBox
     Left = 226
-    Height = 31
+    Height = 21
     Hint = 'All changes from this database to the target database will be listed'
     Top = 136
     Width = 460
-    ItemHeight = 0
+    ItemHeight = 13
     OnChange = cbComparedDatabaseChange
     ParentShowHint = False
     ShowHint = True
@@ -54,9 +54,9 @@ object fmComparison: TfmComparison
   end
   object laComparedDatabase: TLabel
     Left = 226
-    Height = 17
+    Height = 13
     Top = 176
-    Width = 11
+    Width = 10
     Caption = '[]'
     Font.Style = [fsBold]
     ParentColor = False
@@ -65,7 +65,7 @@ object fmComparison: TfmComparison
   object bbStart: TBitBtn
     Left = 549
     Height = 30
-    Top = 288
+    Top = 315
     Width = 154
     Caption = 'Start Comparison'
     Default = True
@@ -110,8 +110,8 @@ object fmComparison: TfmComparison
   end
   object meLog: TMemo
     Left = 15
-    Height = 272
-    Top = 328
+    Height = 248
+    Top = 352
     Width = 674
     Anchors = [akTop, akLeft, akRight, akBottom]
     Font.Name = 'Courier 10 Pitch'
@@ -123,9 +123,9 @@ object fmComparison: TfmComparison
   object laScript: TLabel
     Cursor = crHandPoint
     Left = 16
-    Height = 17
-    Top = 296
-    Width = 272
+    Height = 13
+    Top = 323
+    Width = 193
     Caption = 'Script differences in compared database'
     Font.Style = [fsUnderline]
     ParentColor = False
@@ -134,59 +134,59 @@ object fmComparison: TfmComparison
   end
   object GroupBox1: TGroupBox
     Left = 15
-    Height = 79
+    Height = 112
     Top = 192
     Width = 488
     Caption = 'Compared objects'
-    ClientHeight = 60
+    ClientHeight = 94
     ClientWidth = 484
     TabOrder = 2
     object cxTables: TCheckBox
       Left = 11
-      Height = 24
+      Height = 17
       Top = 4
-      Width = 69
+      Width = 51
       Caption = 'Tables'
       TabOrder = 0
     end
     object cxGenerators: TCheckBox
       Left = 11
-      Height = 24
+      Height = 17
       Top = 32
-      Width = 102
+      Width = 74
       Caption = 'Generators'
       TabOrder = 1
     end
     object cxTriggers: TCheckBox
       Left = 151
-      Height = 24
+      Height = 17
       Top = 4
-      Width = 80
+      Width = 59
       Caption = 'Triggers'
       TabOrder = 2
     end
     object cxViews: TCheckBox
       Left = 151
-      Height = 24
+      Height = 17
       Top = 34
-      Width = 66
+      Width = 47
       Caption = 'Views'
       TabOrder = 3
     end
     object cxStoredProcs: TCheckBox
       Left = 262
-      Height = 24
+      Height = 17
       Top = 4
-      Width = 113
+      Width = 81
       Caption = 'Stored Procs'
       TabOrder = 4
     end
     object cxUDFs: TCheckBox
       Left = 262
-      Height = 24
+      Height = 17
       Hint = 'User Defined Functions'
       Top = 32
-      Width = 61
+      Width = 45
       Caption = 'UDFs'
       ParentShowHint = False
       ShowHint = True
@@ -194,25 +194,33 @@ object fmComparison: TfmComparison
     end
     object cxDomains: TCheckBox
       Left = 390
-      Height = 24
+      Height = 17
       Top = 4
-      Width = 85
+      Width = 60
       Caption = 'Domains'
       TabOrder = 6
     end
     object cxRoles: TCheckBox
       Left = 390
-      Height = 24
+      Height = 17
       Top = 34
-      Width = 63
+      Width = 46
       Caption = 'Roles'
       TabOrder = 7
     end
+    object cxExceptions: TCheckBox
+      Left = 11
+      Height = 17
+      Top = 61
+      Width = 72
+      Caption = 'Exceptions'
+      TabOrder = 8
+    end
   end
   object StatusBar1: TStatusBar
     Left = 0
-    Height = 21
-    Top = 607
+    Height = 20
+    Top = 608
     Width = 710
     Panels = <    
       item
@@ -240,7 +248,7 @@ object fmComparison: TfmComparison
     Top = 8
     Width = 697
     AutoSize = False
-    Caption = 'Database comparison tool compares original database structure to another database structure.'#13#10'It generates a script to make the compared (source) database structure become like the original (target) database.'#13#10'For instance, the original database could be a development database, and compared database is an old version that'#13#10'is deployed at a customer. This tool generates a script to make the customer database structure '#13#10'resemble the developmenent database as much as possible.'
+    Caption = 'Database comparison tool compares original database structure to another database structure.'#13#10'It generates a script to make the compared (source) database structure become like the original (target) database.'#13#10'For instance, the original database could be a development database, and compared database is an old version that'#13#10'is deployed at a customer. This tool generates a script to make the customer database structure '#13#10'resemble the development database as much as possible.'
     Color = clCream
     Font.Height = -11
     ParentColor = False
@@ -250,27 +258,27 @@ object fmComparison: TfmComparison
   end
   object GroupBox2: TGroupBox
     Left = 504
-    Height = 76
+    Height = 108
     Top = 195
     Width = 199
     Caption = 'Options'
-    ClientHeight = 57
+    ClientHeight = 90
     ClientWidth = 195
     TabOrder = 6
     object cxIgnoreLength: TCheckBox
       Left = 11
-      Height = 24
+      Height = 17
       Top = 1
-      Width = 154
+      Width = 113
       Caption = 'Ignore fields length'
       TabOrder = 0
     end
     object cxRemovedObjects: TCheckBox
       Left = 11
-      Height = 24
+      Height = 17
       Hint = 'Check objects present in source but removed in target database'
       Top = 22
-      Width = 182
+      Width = 132
       Caption = 'Check removed objects'
       ParentShowHint = False
       ShowHint = True
@@ -280,7 +288,7 @@ object fmComparison: TfmComparison
   object bbCancel: TBitBtn
     Left = 440
     Height = 30
-    Top = 288
+    Top = 315
     Width = 78
     Caption = 'Cancel'
     Glyph.Data = {

comparison.pas

@@ -23,6 +23,7 @@ type
     cxRemovedObjects: TCheckBox;
     cxDomains: TCheckBox;
     cxRoles: TCheckBox;
+    cxExceptions: TCheckBox;
     cxTriggers: TCheckBox;
     cxGenerators: TCheckBox;
     cxTables: TCheckBox;
@@ -110,6 +111,8 @@ type
     procedure ScriptModifiedFunctions;
     procedure ScriptModifiedDomains;
 
+    // Outputs script to remove db objects to query window
+    // Requires FDBRemovedObjectsList to be filled in advance
     procedure ScriptRemovedDBObjects;
     procedure ScriptRemovedFields;
   public
@@ -342,6 +345,7 @@ var
   Collation: string;
   DomainType, DefaultValue: string;
   DomainSize: Integer;
+  ExceptionMesage, ExceptionDescription, ExceptionSQL: string;
   ATableName, AIndexName: string;
   FieldsList: TStringList;
   Unique, Ascending: Boolean;
@@ -530,6 +534,18 @@ begin
         FQueryWindow.meQuery.Lines.Add('');
       end
       else
+      if (ObjectType = otExceptions) and cxExceptions.Checked then // Exceptions
+      for i:= 0 to FDBObjectsList[ord(ObjectType)].Count - 1 do
+      begin
+        ScriptList.Clear;
+        if (dmSysTables.GetExceptionInfo(FDBIndex, FDBObjectsList[ord(ObjectType)].Strings[i],
+          ExceptionMesage, ExceptionDescription, ExceptionSQL, true)) then
+          FQueryWindow.meQuery.Lines.Add(ExceptionSQL)
+        else
+          raise Exception.Create('Error scripting exception '+FDBObjectsList[ord(ObjectType)].Strings[i]);
+        FQueryWindow.meQuery.Lines.Add('');
+      end
+      else
       if (ObjectType = otTables) and cxTables.Checked then // Indices are part of tables
       for i:= 0 to FDBObjectsList[ord(ObjectType)].Count - 1 do
       begin
@@ -627,10 +643,9 @@ begin
          ((ObjectType = otUDF) and cxUDFs.Checked) or
          {otSystemTables: system tables are not compared }
          ((ObjectType = otDomains) and cxDomains.Checked) or
-         ((ObjectType = otRoles) and cxRoles.Checked)
-         {otExceptions, otUsers are not checked;
-         constraints and indexes probably indirectly}
-         //todo: check otExceptions in CheckMissingDBObjects
+         ((ObjectType = otRoles) and cxRoles.Checked) or
+         ((ObjectType = otExceptions) and cxExceptions.Checked)
+         {otUsers are not compared}
          then
       begin
         meLog.Lines.Add('');
@@ -683,10 +698,10 @@ begin
        ((ObjectType = otStoredProcedures) and cxStoredProcs.Checked) or
        ((ObjectType = otUDF) and cxUDFs.Checked) or
        {otSystemTables: system tables are not compared }
-       ((ObjectType = otDomains) and cxDomains.Checked)
-       {otRoles, otExceptions, otUsers are not checked;
-         constraints and indexes probably indirectly}
-       //todo: check otExceptions in CheckRemovedDBObjects
+       ((ObjectType = otDomains) and cxDomains.Checked) or
+       ((ObjectTYpe = otRoles) and cxRoles.Checked) or
+       ((ObjectType = otExceptions) and cxExceptions.Checked)
+       {otUsers are not checked}
        then
     begin
       meLog.Lines.Add('');
@@ -708,11 +723,13 @@ begin
       FDBRemovedObjectsList[ord(ObjectType)].Clear;
 
       for i:= 0 to ComparedList.Count -1 do
-      if List.IndexOf(ComparedList[i]) = -1 then  // Removed
       begin
-        meLog.Lines.Add(' ' + ComparedList[i]);
-        FDBRemovedObjectsList[ord(ObjectType)].Add(ComparedList[i]);
-        Inc(FDiffCount);
+        if List.IndexOf(ComparedList[i]) = -1 then  // Removed
+        begin
+          meLog.Lines.Add(' ' + ComparedList[i]);
+          FDBRemovedObjectsList[ord(ObjectType)].Add(ComparedList[i]);
+          Inc(FDiffCount);
+        end;
       end;
     end;
     CheckRemovedIndices;
@@ -1821,6 +1838,20 @@ begin
         end;
       end
       else
+      if (ObjectType = otExceptions) and cxExceptions.Checked then
+      begin
+        if FDBRemovedObjectsList[ord(ObjectType)].Count > 0 then
+        begin
+          FQueryWindow.meQuery.Lines.Add('');
+          FQueryWindow.meQuery.Lines.Add('-- Removed Exceptions');
+        end;
+        for i:= 0 to FDBRemovedObjectsList[ord(ObjectType)].Count - 1 do
+        begin
+          ObjName:= FDBRemovedObjectsList[ord(ObjectType)][i];
+          FQueryWindow.meQuery.Lines.Add('drop exception ' + ObjName + ';');
+        end;
+      end
+      else
       if (ObjectType = otIndexes) and cxTables.Checked then // Indices are linked to tables
       begin
         if FDBRemovedObjectsList[ord(ObjectType)].Count > 0 then
@@ -1863,7 +1894,6 @@ begin
   finally
     FieldsList.Free;
   end;
-
 end;
 
 procedure TfmComparison.ScriptRemovedFields;
@@ -1903,6 +1933,7 @@ begin
   cxUDFs.Checked:= True;
   cxTriggers.Checked:= True;
   cxRoles.Checked:= True;
+  cxExceptions.Checked:= True;
   cxRemovedObjects.Checked:= False;
 
   laScript.Enabled:= False;

main.pas

@@ -1901,7 +1901,8 @@ var
   Script, Msg, Desc: string;
 begin
   SelNode:= tvMain.Selected;
-  if dmSysTables.GetExceptionInfo(SelNode.Text, Msg, Desc, Script) then
+  if dmSysTables.GetExceptionInfo(PtrInt(tvMain.Selected.Data), SelNode.Text,
+    Msg, Desc, Script, false) then
     ShowCompleteQueryWindow(PtrInt(SelNode.Parent.Parent.Data), 'Script Exception ' + SelNode.Text, Script, nil);
 end;
 

scriptdb.pas

@@ -143,7 +143,8 @@ begin
   List.CommaText:= dmSysTables.GetDBObjectNames(dbIndex, otExceptions, Count);
   for i:= 0 to List.Count - 1 do
   begin
-    dmSysTables.GetExceptionInfo(List[i],Message, Description, CreateStatement);
+    dmSysTables.GetExceptionInfo(dbIndex, List[i],
+      Message, Description, CreateStatement, false);
     List[i]:= CreateStatement;
   end;
   Result:= List.Count > 0;

systables.pas

@@ -34,7 +34,7 @@ type
       var ConstraintsArray: TConstraintCounts);
     procedure Init(dbIndex: Integer);
     // Gets list of object names that have type specified by TVIndex
-    // Returns Count of objects in Count
+    // Returns count of objects in Count
     function GetDBObjectNames(DatabaseIndex: integer; ObjectType: TObjectType; var Count: Integer): string;
     // Returns object list (list of object names, i.e. tables, views) sorted by dependency
     // Limits sorting within one category (e.g. views)
@@ -58,14 +58,15 @@ type
     // Expects array that has been filled by FillCompositeFKConstraints
     function GetCompositeFKConstraint(const ConstraintName: string; ConstraintsArray: TConstraintCounts): integer;
 
-    function GetConstraintInfo(dbIndex: Integer; ATableName, ConstraintName: string; var KeyName,
+    function GetConstraintInfo(dbIndex: integer; ATableName, ConstraintName: string; var KeyName,
         CurrentTableName, CurrentFieldName, OtherTableName, OtherFieldName, UpdateRule, DeleteRule: string): Boolean;
 
     // Gets information about exception.
-    // Returns CREATE EXCEPTION statement in SQLQuery.
-    function GetExceptionInfo(ExceptionName: string; var Msg, Description, SqlQuery: string): Boolean;
+    // Returns CREATE EXCEPTION statement in SQLQuery, or
+    // CREATE OR ALTER EXCEPTION if CreateOrAlter is true
+    function GetExceptionInfo(dbIndex: integer; ExceptionName: string; var Msg, Description, SqlQuery: string; CreateOrAlter: boolean): Boolean;
     // Gets information about domain
-    procedure GetDomainInfo(dbIndex: Integer; DomainName: string; var DomainType: string;
+    procedure GetDomainInfo(dbIndex: integer; DomainName: string; var DomainType: string;
       var DomainSize: Integer; var DefaultValue: string; var CheckConstraint: string; var CharacterSet: string; var Collation: string);
     function GetConstraintForeignKeyFields(AIndexName: string; SqlQuery: TSQLQuery): string;
 
@@ -136,6 +137,8 @@ end;
 
 procedure TdmSysTables.Init(dbIndex: Integer);
 begin
+  // todo: first step: do not close, reopen connection if we're using the correct
+  // connection/transaction already
   with fmMain.RegisteredDatabases[dbIndex] do
   begin
     if IBConnection.Connected then
@@ -196,7 +199,7 @@ begin
   if ObjectType = otUsers then // Users
     sqQuery.SQL.Text:= 'select distinct RDB$User from RDB$USER_PRIVILEGES where RDB$User_Type = 8 order by rdb$User';
 
-  // Put the result list as comma delimited string
+  // Save the result list as comma delimited string
   sqQuery.Open;
   while not sqQuery.EOF do
   begin
@@ -615,19 +618,26 @@ end;
 
 (*********  Get Exception Info ***************)
 
-function TdmSysTables.GetExceptionInfo(ExceptionName: string; var Msg, Description,
-  SqlQuery: string): Boolean;
+function TdmSysTables.GetExceptionInfo(dbIndex: integer; ExceptionName: string; var Msg, Description,
+  SqlQuery: string; CreateOrAlter: boolean): Boolean;
+var
+  CreatePart: string;
 begin
   sqQuery.Close;
+  init(dbIndex);
   sqQuery.SQL.Text:= 'select * from RDB$EXCEPTIONS ' +
    'where RDB$EXCEPTION_NAME = ' + QuotedStr(ExceptionName);
   sqQuery.Open;
   Result:= sqQuery.RecordCount > 0;
   if Result then
   begin
+    if CreateOrAlter then
+      CreatePart:= 'CREATE OR ALTER EXCEPTION ' {Since Firebird 2.0; create or replace existing}
+    else
+      CreatePart:= 'CREATE EXCEPTION ';
     Msg:= sqQuery.FieldByName('RDB$MESSAGE').AsString;
     Description:= sqQuery.FieldByName('RDB$DESCRIPTION').AsString;
-    SqlQuery:= 'CREATE EXCEPTION ' + ExceptionName + LineEnding +
+    SqlQuery:= CreatePart + ExceptionName + LineEnding +
       QuotedStr(Msg) + ';';
     if Description<>'' then
       SQLQuery:= SQLQuery + LineEnding +