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, 2 months ago) by tony
Content type:	text/x-pascal
File size:	5518 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	143	(*
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	tony	37	unit Unit1;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35	tony	45	ComCtrls, ActnList, ExtCtrls, ibxscript, IBDatabase, IB;
36	tony	37
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	tony	47	procedure IBDatabase1BeforeConnect(Sender: TObject);
65	tony	37	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	tony	47	// Application.QueueAsyncCall(@DoOpen,0);
102	tony	37	end;
103
104	tony	47	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	tony	37	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	tony	47	IBXScript1.RunScript(IBScript.Lines);
180	tony	37	Timer1.Interval := 1000;
181	tony	47	EchoInput.Checked := IBXScript1.Echo;
182			StopOnError.Checked := IBXScript1.StopOnFirstError;
183			DBName.Caption := IBDatabase1.DatabaseName;
184	tony	37	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