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
#	Content
1	(*
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