examples/scriptengine/unit1.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 Unit1;

{$mode objfpc}{$H+}

interface

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

type

  { TForm1 }

  TForm1 = class(TForm)
    EchoInput: TCheckBox;
    OpenBlobDialog: TOpenDialog;
    StopOnError: TCheckBox;
    RunScript: TAction;
    LoadScript: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    IBDatabase1: TIBDatabase;
    IBTransaction1: TIBTransaction;
    IBXScript1: TIBXScript;
    Label1: TLabel;
    Label2: TLabel;
    IBScript: TMemo;
    Label3: TLabel;
    DBName: TLabel;
    OpenDialog1: TOpenDialog;
    ProgressBar1: TProgressBar;
    ResultsLog: TMemo;
    Timer1: TTimer;
    procedure EchoInputChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1BeforeConnect(Sender: TObject);
    procedure IBXScript1GetParamValue(Sender: TObject; ParamName: string;
      var BlobID: TISC_QUAD);
    procedure IBXScript1LogProc(Sender: TObject; Msg: string);
    procedure IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
      value: integer);
    procedure IBXScript1SelectSQL(Sender: TObject; SQLText: string);
    procedure LoadScriptExecute(Sender: TObject);
    procedure RunScriptExecute(Sender: TObject);
    procedure RunScriptUpdate(Sender: TObject);
    procedure StopOnErrorChange(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { private declarations }
    procedure DoOpen(Data: PtrInt);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

uses IBBlob, DB, Unit2;

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormShow(Sender: TObject);
begin
  ResultsLog.Lines.Clear;
  IBScript.Lines.Clear;
  DBName.Caption := IBDatabase1.DatabaseName;
  StopOnError.Checked := IBXScript1.StopOnFirstError;
  EchoInput.Checked :=  IBXScript1.Echo;
//  Application.QueueAsyncCall(@DoOpen,0);
end;

procedure TForm1.IBDatabase1BeforeConnect(Sender: TObject);
begin
  with (Sender as TIBDatabase) do
  begin
    LoginPrompt := (Params.IndexOfName('user_name') = -1) or
                   (Params.IndexOfName('password') = -1);
  end;
end;

procedure TForm1.EchoInputChange(Sender: TObject);
begin
  IBXScript1.Echo :=  EchoInput.Checked;
end;

procedure TForm1.IBXScript1GetParamValue(Sender: TObject; ParamName: string;
  var BlobID: TISC_QUAD);
var Blob: TIBBlobStream;
    Source: TStream;
begin
  OpenBlobDialog.Title := 'Resolve Query Parameter: ''' + ParamName + '''';
  if OpenBlobDialog.Execute then
  begin
    ResultsLog.Lines.Add('Loading ' + ParamName + ' from ' + OpenBlobDialog.FileName);
    Blob := TIBBlobStream.Create;
    try
      Blob.Database := (Sender as TIBXScript).Database;
      Blob.Mode := bmWrite;
      Source := TFileStream.Create(OpenBlobDialog.FileName,fmOpenRead or fmShareDenyNone);
      try
        Blob.CopyFrom(Source,0)
      finally
        Source.Free;
      end;
      Blob.Finalize;
      BlobID := Blob.BlobID;
    finally
      Blob.Free;
    end;
  end
  else
    raise Exception.Create('Unable to resolve statement parameter');
end;

procedure TForm1.IBXScript1LogProc(Sender: TObject; Msg: string);
begin
  ResultsLog.Lines.Add(Msg);
end;

procedure TForm1.IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
  value: integer);
begin
  if Reset then
  begin
    ProgressBar1.Position :=  0;
    ProgressBar1.Max := value;
  end
  else
    ProgressBar1.StepIt;
end;

procedure TForm1.IBXScript1SelectSQL(Sender: TObject; SQLText: string);
begin
  with TSelectSQLResults.Create(Application) do
    Show(SQLText);
end;

procedure TForm1.LoadScriptExecute(Sender: TObject);
begin
  if OpenDialog1.Execute then
    IBScript.Lines.LoadFromFile(OpenDialog1.FileName);
end;

procedure TForm1.RunScriptExecute(Sender: TObject);
begin
  ResultsLog.Lines.Clear;
  IBXScript1.RunScript(IBScript.Lines);
  Timer1.Interval := 1000;
  EchoInput.Checked := IBXScript1.Echo;
  StopOnError.Checked := IBXScript1.StopOnFirstError;
  DBName.Caption := IBDatabase1.DatabaseName;
end;

procedure TForm1.RunScriptUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := IBScript.Lines.Text <> '';
end;

procedure TForm1.StopOnErrorChange(Sender: TObject);
begin
   IBXScript1.StopOnFirstError := StopOnError.Checked;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Interval := 0;
  ProgressBar1.Position := 0;
end;

procedure TForm1.DoOpen(Data: PtrInt);
begin
  try
    IBDatabase1.Connected := true;
  except on E: Exception do
    begin
      MessageDlg(E.Message,mtError,[mbOK],0);
      Application.Terminate;
    end;
  end;
end;

end.

Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5518 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 Unit1;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35	ComCtrls, ActnList, ExtCtrls, ibxscript, IBDatabase, IB;
36
37	type
38
39	{ TForm1 }
40
41	TForm1 = class(TForm)
42	EchoInput: TCheckBox;
43	OpenBlobDialog: TOpenDialog;
44	StopOnError: TCheckBox;
45	RunScript: TAction;
46	LoadScript: TAction;
47	ActionList1: TActionList;
48	Button1: TButton;
49	Button2: TButton;
50	IBDatabase1: TIBDatabase;
51	IBTransaction1: TIBTransaction;
52	IBXScript1: TIBXScript;
53	Label1: TLabel;
54	Label2: TLabel;
55	IBScript: TMemo;
56	Label3: TLabel;
57	DBName: TLabel;
58	OpenDialog1: TOpenDialog;
59	ProgressBar1: TProgressBar;
60	ResultsLog: TMemo;
61	Timer1: TTimer;
62	procedure EchoInputChange(Sender: TObject);
63	procedure FormShow(Sender: TObject);
64	procedure IBDatabase1BeforeConnect(Sender: TObject);
65	procedure IBXScript1GetParamValue(Sender: TObject; ParamName: string;
66	var BlobID: TISC_QUAD);
67	procedure IBXScript1LogProc(Sender: TObject; Msg: string);
68	procedure IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
69	value: integer);
70	procedure IBXScript1SelectSQL(Sender: TObject; SQLText: string);
71	procedure LoadScriptExecute(Sender: TObject);
72	procedure RunScriptExecute(Sender: TObject);
73	procedure RunScriptUpdate(Sender: TObject);
74	procedure StopOnErrorChange(Sender: TObject);
75	procedure Timer1Timer(Sender: TObject);
76	private
77	{ private declarations }
78	procedure DoOpen(Data: PtrInt);
79	public
80	{ public declarations }
81	end;
82
83	var
84	Form1: TForm1;
85
86	implementation
87
88	uses IBBlob, DB, Unit2;
89
90	{$R *.lfm}
91
92	{ TForm1 }
93
94	procedure TForm1.FormShow(Sender: TObject);
95	begin
96	ResultsLog.Lines.Clear;
97	IBScript.Lines.Clear;
98	DBName.Caption := IBDatabase1.DatabaseName;
99	StopOnError.Checked := IBXScript1.StopOnFirstError;
100	EchoInput.Checked := IBXScript1.Echo;
101	// Application.QueueAsyncCall(@DoOpen,0);
102	end;
103
104	procedure TForm1.IBDatabase1BeforeConnect(Sender: TObject);
105	begin
106	with (Sender as TIBDatabase) do
107	begin
108	LoginPrompt := (Params.IndexOfName('user_name') = -1) or
109	(Params.IndexOfName('password') = -1);
110	end;
111	end;
112
113	procedure TForm1.EchoInputChange(Sender: TObject);
114	begin
115	IBXScript1.Echo := EchoInput.Checked;
116	end;
117
118	procedure TForm1.IBXScript1GetParamValue(Sender: TObject; ParamName: string;
119	var BlobID: TISC_QUAD);
120	var Blob: TIBBlobStream;
121	Source: TStream;
122	begin
123	OpenBlobDialog.Title := 'Resolve Query Parameter: ''' + ParamName + '''';
124	if OpenBlobDialog.Execute then
125	begin
126	ResultsLog.Lines.Add('Loading ' + ParamName + ' from ' + OpenBlobDialog.FileName);
127	Blob := TIBBlobStream.Create;
128	try
129	Blob.Database := (Sender as TIBXScript).Database;
130	Blob.Mode := bmWrite;
131	Source := TFileStream.Create(OpenBlobDialog.FileName,fmOpenRead or fmShareDenyNone);
132	try
133	Blob.CopyFrom(Source,0)
134	finally
135	Source.Free;
136	end;
137	Blob.Finalize;
138	BlobID := Blob.BlobID;
139	finally
140	Blob.Free;
141	end;
142	end
143	else
144	raise Exception.Create('Unable to resolve statement parameter');
145	end;
146
147	procedure TForm1.IBXScript1LogProc(Sender: TObject; Msg: string);
148	begin
149	ResultsLog.Lines.Add(Msg);
150	end;
151
152	procedure TForm1.IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
153	value: integer);
154	begin
155	if Reset then
156	begin
157	ProgressBar1.Position := 0;
158	ProgressBar1.Max := value;
159	end
160	else
161	ProgressBar1.StepIt;
162	end;
163
164	procedure TForm1.IBXScript1SelectSQL(Sender: TObject; SQLText: string);
165	begin
166	with TSelectSQLResults.Create(Application) do
167	Show(SQLText);
168	end;
169
170	procedure TForm1.LoadScriptExecute(Sender: TObject);
171	begin
172	if OpenDialog1.Execute then
173	IBScript.Lines.LoadFromFile(OpenDialog1.FileName);
174	end;
175
176	procedure TForm1.RunScriptExecute(Sender: TObject);
177	begin
178	ResultsLog.Lines.Clear;
179	IBXScript1.RunScript(IBScript.Lines);
180	Timer1.Interval := 1000;
181	EchoInput.Checked := IBXScript1.Echo;
182	StopOnError.Checked := IBXScript1.StopOnFirstError;
183	DBName.Caption := IBDatabase1.DatabaseName;
184	end;
185
186	procedure TForm1.RunScriptUpdate(Sender: TObject);
187	begin
188	(Sender as TAction).Enabled := IBScript.Lines.Text <> '';
189	end;
190
191	procedure TForm1.StopOnErrorChange(Sender: TObject);
192	begin
193	IBXScript1.StopOnFirstError := StopOnError.Checked;
194	end;
195
196	procedure TForm1.Timer1Timer(Sender: TObject);
197	begin
198	Timer1.Interval := 0;
199	ProgressBar1.Position := 0;
200	end;
201
202	procedure TForm1.DoOpen(Data: PtrInt);
203	begin
204	try
205	IBDatabase1.Connected := true;
206	except on E: Exception do
207	begin
208	MessageDlg(E.Message,mtError,[mbOK],0);
209	Application.Terminate;
210	end;
211	end;
212	end;
213
214	end.
215