iblocaldb/gui/IBXCreateDatabaseFromSQLDlgUnit.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  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 here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  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 Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit IBXCreateDatabaseFromSQLDlgUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  StdCtrls, ComCtrls, ibxscript, IB, IBDatabase;

type

  { TIBXCreateDatabaseFromSQLDlg }

  TIBXCreateDatabaseFromSQLDlg = class(TForm)
    Bevel1: TBevel;
    IBXScript: TIBXScript;
    Label1: TLabel;
    ProgressBar: TProgressBar;
    procedure FormShow(Sender: TObject);
    procedure IBXScriptCreateDatabase(Sender: TObject;
      var DatabaseFileName: string);
    procedure IBXScriptProgressEvent(Sender: TObject; Reset: boolean;
      value: integer);
  private
    FDatabasePath: string;
    FFileName: string;
    procedure DoRunScript(Data: PtrInt);
  public
    property FileName: string read FFileName write FFileName;
    property DatabasePath: string read FDatabasePath write FDatabasePath;
  end;

var
  IBXCreateDatabaseFromSQLDlg: TIBXCreateDatabaseFromSQLDlg;

function CreateNewDatabase(aDatabase: TIBDatabase; DBArchive: string): boolean;

implementation

uses IBErrorCodes;

function CreateNewDatabase(aDatabase: TIBDatabase;
  DBArchive: string): boolean;
begin
  with TIBXCreateDatabaseFromSQLDlg.Create(Application) do
  try
    FileName := DBArchive;
    IBXScript.Database := aDatabase;
    IBXScript.Transaction := aDatabase.DefaultTransaction;
    DatabasePath := aDatabase.DatabaseName;
    Result := ShowModal = mrOK;
  finally
    Free
  end
end;

{$R *.lfm}

{ TIBXCreateDatabaseFromSQLDlg }

procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptProgressEvent(Sender: TObject;
  Reset: boolean; value: integer);
begin
  if Reset then
    ProgressBar.Max := value
  else
    ProgressBar.StepIt;
  Application.ProcessMessages;
end;

procedure TIBXCreateDatabaseFromSQLDlg.DoRunScript(Data: PtrInt);
begin
  try
    ModalResult := mrCancel;
    IBXScript.Database.CreateDatabase; {try to create the database}
    repeat
      try
        if IBXScript.RunScript(FileName) then
          ModalResult := mrOK;
        break;
      except on E:EIBInterBaseError do
      begin
        writeln(E.IBErrorCode);
        if (E.IBErrorCode = isc_io_error) or  (E.IBErrorCode = isc_db_or_file_exists) then
          {script contains Create Database Statement}
        begin
          IBXScript.Database.Connected := true;
          IBXScript.Database.DropDatabase;
          {repeat above and let script create database}
        end
        else
          raise;
      end;
      end;
    until false;
    with IBXScript.Transaction do
      if InTransaction then Commit;
    IBXScript.Database.Connected := false;
  except on E:Exception do
    begin
      MessageDlg(E.Message,mtError,[mbOK],0);
      Close;
    end;
  end;
end;

procedure TIBXCreateDatabaseFromSQLDlg.FormShow(Sender: TObject);
begin
  ProgressBar.Position := 0;
  Application.QueueAsyncCall(@DoRunScript,0);
end;

procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptCreateDatabase(Sender: TObject;
  var DatabaseFileName: string);
begin
  DatabaseFileName := DatabasePath;
end;

end.

Revision:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	3883 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	209	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2015 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26
27			unit IBXCreateDatabaseFromSQLDlgUnit;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
35			StdCtrls, ComCtrls, ibxscript, IB, IBDatabase;
36
37			type
38
39			{ TIBXCreateDatabaseFromSQLDlg }
40
41			TIBXCreateDatabaseFromSQLDlg = class(TForm)
42			Bevel1: TBevel;
43			IBXScript: TIBXScript;
44			Label1: TLabel;
45			ProgressBar: TProgressBar;
46			procedure FormShow(Sender: TObject);
47			procedure IBXScriptCreateDatabase(Sender: TObject;
48			var DatabaseFileName: string);
49			procedure IBXScriptProgressEvent(Sender: TObject; Reset: boolean;
50			value: integer);
51			private
52			FDatabasePath: string;
53			FFileName: string;
54			procedure DoRunScript(Data: PtrInt);
55			public
56			property FileName: string read FFileName write FFileName;
57			property DatabasePath: string read FDatabasePath write FDatabasePath;
58			end;
59
60			var
61			IBXCreateDatabaseFromSQLDlg: TIBXCreateDatabaseFromSQLDlg;
62
63			function CreateNewDatabase(aDatabase: TIBDatabase; DBArchive: string): boolean;
64
65			implementation
66
67			uses IBErrorCodes;
68
69			function CreateNewDatabase(aDatabase: TIBDatabase;
70			DBArchive: string): boolean;
71			begin
72			with TIBXCreateDatabaseFromSQLDlg.Create(Application) do
73			try
74			FileName := DBArchive;
75			IBXScript.Database := aDatabase;
76			IBXScript.Transaction := aDatabase.DefaultTransaction;
77			DatabasePath := aDatabase.DatabaseName;
78			Result := ShowModal = mrOK;
79			finally
80			Free
81			end
82			end;
83
84			{$R *.lfm}
85
86			{ TIBXCreateDatabaseFromSQLDlg }
87
88			procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptProgressEvent(Sender: TObject;
89			Reset: boolean; value: integer);
90			begin
91			if Reset then
92			ProgressBar.Max := value
93			else
94			ProgressBar.StepIt;
95			Application.ProcessMessages;
96			end;
97
98			procedure TIBXCreateDatabaseFromSQLDlg.DoRunScript(Data: PtrInt);
99			begin
100			try
101			ModalResult := mrCancel;
102			IBXScript.Database.CreateDatabase; {try to create the database}
103			repeat
104			try
105			if IBXScript.RunScript(FileName) then
106			ModalResult := mrOK;
107			break;
108			except on E:EIBInterBaseError do
109			begin
110			writeln(E.IBErrorCode);
111			if (E.IBErrorCode = isc_io_error) or (E.IBErrorCode = isc_db_or_file_exists) then
112			{script contains Create Database Statement}
113			begin
114			IBXScript.Database.Connected := true;
115			IBXScript.Database.DropDatabase;
116			{repeat above and let script create database}
117			end
118			else
119			raise;
120			end;
121			end;
122			until false;
123			with IBXScript.Transaction do
124			if InTransaction then Commit;
125			IBXScript.Database.Connected := false;
126			except on E:Exception do
127			begin
128			MessageDlg(E.Message,mtError,[mbOK],0);
129			Close;
130			end;
131			end;
132			end;
133
134			procedure TIBXCreateDatabaseFromSQLDlg.FormShow(Sender: TObject);
135			begin
136			ProgressBar.Position := 0;
137			Application.QueueAsyncCall(@DoRunScript,0);
138			end;
139
140			procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptCreateDatabase(Sender: TObject;
141			var DatabaseFileName: string);
142			begin
143			DatabaseFileName := DatabasePath;
144			end;
145
146			end.
147