trunk/testsuite/Test27.pas

(*
 *  IBX Test suite. This program is used to test the IBX non-visual
 *  components and provides a semi-automated pass/fail check for each test.
 *
 *  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) 2021 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)      
unit Test27;

{$mode objfpc}{$H+}

{Test 27: create, bring up-to-date and read from local database}

{
  Requires Firebird Embedded Server - with FB 2.5 and lower this implies FBEmbedded

  Creates a new local database from a backup archive.

  Updates the schema

  Prints out results of a query.
}

interface

uses
  Classes, SysUtils,  TestApplication, IBXTestBase, IB, IBCMLocalDBSupport, IBSQL,
  IBQuery, IBDatabase;

const
  aTestID    = '27';
  aTestTitle = 'create, bring up-to-date and read from local database';

type

{ TTest27 }

  TTest27 = class(TIBXTestBase)
  private
    FLocalDB: TIBCMLocalDBSupport;
    procedure HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
    procedure HandleLogMessage(Sender: TObject; Msg: string);
    procedure GetSharedDirectory(Sender: TObject; var SharedDataDir: string);
  protected
    procedure CreateObjects(Application: TTestApplication); override;
    function GetTestID: AnsiString; override;
    function GetTestTitle: AnsiString; override;
    procedure InitTest; override;
  public
    procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
  end;


implementation

const
  sqlExample =
'with recursive Depts As (   '+
'Select DEPT_NO, DEPARTMENT, HEAD_DEPT, cast(DEPARTMENT  as VarChar(256)) as DEPT_PATH,'+
'cast(DEPT_NO as VarChar(64)) as DEPT_KEY_PATH '+
'From DEPARTMENT Where HEAD_DEPT is NULL '+
'UNION ALL '+
'Select D.DEPT_NO, D.DEPARTMENT, D.HEAD_DEPT, Depts.DEPT_PATH ||  '' / '' || D.DEPARTMENT as DEPT_PATH,'+
'Depts.DEPT_KEY_PATH || '';'' || D.DEPT_NO as DEPT_KEY_PATH '+
'From DEPARTMENT D '+
'JOIN Depts On D.HEAD_DEPT = Depts.DEPT_NO '+
')'+

'Select First 2 A.EMP_NO, A.FIRST_NAME, A.LAST_NAME, A.PHONE_EXT, A.HIRE_DATE, A.DEPT_NO, A.JOB_CODE,'+
'A.JOB_GRADE, A.JOB_COUNTRY, A.SALARY, A.FULL_NAME, A.PHOTO, D.DEPT_PATH, D.DEPT_KEY_PATH '+
'From EMPLOYEE A '+
'JOIN Depts D On D.DEPT_NO = A.DEPT_NO';

  { TTest27 }

procedure TTest27.HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
begin
  VersionNo := 0;
  IBTransaction.Active := true;
  try
    with TIBSQL.Create(Owner) do
    try
      Database := IBDatabase;
      Transaction := IBTransaction;
      SQL.Text := 'Select * From RDB$RELATIONS Where RDB$RELATION_NAME = ''DBVERSIONINFO''';
      ExecQuery;
      try
        if EOF then Exit;
      finally
        Close;
      end;
    finally
      Free
    end;

    with TIBSQL.Create(Owner)  do
    try
      Database := IBDatabase;
      Transaction := IBTransaction;
      SQL.Text := 'Select VersionNo From DBVersionInfo';
      ExecQuery;
      try
        VersionNo := FieldByName('VersionNo').AsInteger;
      finally
        Close;
      end;
    finally
      Free;
    end;
  finally
    IBTransaction.Commit;
  end;
end;

procedure TTest27.HandleLogMessage(Sender: TObject; Msg: string);
begin
  writeln(OutFile,Msg);
end;

procedure TTest27.GetSharedDirectory(Sender: TObject; var SharedDataDir: string);
begin
  SharedDataDir := 'resources/Test27';
end;

procedure TTest27.CreateObjects(Application: TTestApplication);
begin
  inherited CreateObjects(Application);
  FLocalDB := TIBCMLocalDBSupport.Create(Application);
  FLocalDB.Database := IBDatabase;
  FLocalDB.VendorName := 'MWA Software';
  FLocalDB.OnGetDBVersionNo := @HandleGetDBVersionNo;
  FLocalDB.OnLogMessage := @HandleLogMessage;
  FLocalDB.OnGetSharedDataDir := @GetSharedDirectory;
end;

function TTest27.GetTestID: AnsiString;
begin
  Result := aTestID;
end;

function TTest27.GetTestTitle: AnsiString;
begin
  Result := aTestTitle;
end;

procedure TTest27.InitTest;
begin
  IBDatabase.DatabaseName := 'nemo';
  FLocalDB.DatabaseName := ExtractDBName(Owner.GetNewDatabaseName);
  FLocalDB.EmptyDBArchive := 'employee.gbk';
  FLocalDB.RequiredVersionNo := 2;
  FLocalDB.UpgradeConfFile := 'upgrade.conf';
  ReadOnlyTransaction;
end;

procedure TTest27.RunTest(CharSet: AnsiString; SQLDialect: integer);
begin
  try
    IBDatabase.Connected := true;
    with IBQuery do
    begin
      AllowAutoActivateTransaction := true;
      SQL.Text := sqlExample;
      Active := true;
      PrintDataSet(IBQuery);
    end;
 finally
    IBDatabase.DropDatabase;
  end;
end;

initialization
  RegisterTest(TTest27);

end.

Revision:	380
Committed:	Mon Jan 10 10:13:17 2022 UTC (2 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	5181 byte(s)
Log Message:	propset for eol-style
#	User	Rev	Content
1	tony	323	(*
2			* IBX Test suite. This program is used to test the IBX non-visual
3			* components and provides a semi-automated pass/fail check for each test.
4			*
5			* The contents of this file are subject to the Initial Developer's
6			* Public License Version 1.0 (the "License"); you may not use this
7			* file except in compliance with the License. You may obtain a copy
8			* of the License here:
9			*
10			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11			*
12			* Software distributed under the License is distributed on an "AS
13			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14			* implied. See the License for the specific language governing rights
15			* and limitations under the License.
16			*
17			* The Initial Developer of the Original Code is Tony Whyman.
18			*
19			* The Original Code is (C) 2021 Tony Whyman, MWA Software
20			* (http://www.mwasoftware.co.uk).
21			*
22			* All Rights Reserved.
23			*
24			* Contributor(s): ______________________________________.
25			*
26			*)
27	tony	315	unit Test27;
28
29			{$mode objfpc}{$H+}
30
31			{Test 27: create, bring up-to-date and read from local database}
32
33			{
34			Requires Firebird Embedded Server - with FB 2.5 and lower this implies FBEmbedded
35
36			Creates a new local database from a backup archive.
37
38			Updates the schema
39
40			Prints out results of a query.
41			}
42
43			interface
44
45			uses
46			Classes, SysUtils, TestApplication, IBXTestBase, IB, IBCMLocalDBSupport, IBSQL,
47			IBQuery, IBDatabase;
48
49			const
50			aTestID = '27';
51			aTestTitle = 'create, bring up-to-date and read from local database';
52
53			type
54
55			{ TTest27 }
56
57			TTest27 = class(TIBXTestBase)
58			private
59			FLocalDB: TIBCMLocalDBSupport;
60			procedure HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
61			procedure HandleLogMessage(Sender: TObject; Msg: string);
62			procedure GetSharedDirectory(Sender: TObject; var SharedDataDir: string);
63			protected
64			procedure CreateObjects(Application: TTestApplication); override;
65			function GetTestID: AnsiString; override;
66			function GetTestTitle: AnsiString; override;
67			procedure InitTest; override;
68			public
69			procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
70			end;
71
72
73			implementation
74
75			const
76			sqlExample =
77			'with recursive Depts As ( '+
78			'Select DEPT_NO, DEPARTMENT, HEAD_DEPT, cast(DEPARTMENT as VarChar(256)) as DEPT_PATH,'+
79			'cast(DEPT_NO as VarChar(64)) as DEPT_KEY_PATH '+
80			'From DEPARTMENT Where HEAD_DEPT is NULL '+
81			'UNION ALL '+
82			'Select D.DEPT_NO, D.DEPARTMENT, D.HEAD_DEPT, Depts.DEPT_PATH \|\| '' / '' \|\| D.DEPARTMENT as DEPT_PATH,'+
83			'Depts.DEPT_KEY_PATH \|\| '';'' \|\| D.DEPT_NO as DEPT_KEY_PATH '+
84			'From DEPARTMENT D '+
85			'JOIN Depts On D.HEAD_DEPT = Depts.DEPT_NO '+
86			')'+
87
88			'Select First 2 A.EMP_NO, A.FIRST_NAME, A.LAST_NAME, A.PHONE_EXT, A.HIRE_DATE, A.DEPT_NO, A.JOB_CODE,'+
89			'A.JOB_GRADE, A.JOB_COUNTRY, A.SALARY, A.FULL_NAME, A.PHOTO, D.DEPT_PATH, D.DEPT_KEY_PATH '+
90			'From EMPLOYEE A '+
91			'JOIN Depts D On D.DEPT_NO = A.DEPT_NO';
92
93			{ TTest27 }
94
95			procedure TTest27.HandleGetDBVersionNo(Sender: TObject; var VersionNo: integer);
96			begin
97			VersionNo := 0;
98			IBTransaction.Active := true;
99			try
100			with TIBSQL.Create(Owner) do
101			try
102			Database := IBDatabase;
103			Transaction := IBTransaction;
104			SQL.Text := 'Select * From RDB$RELATIONS Where RDB$RELATION_NAME = ''DBVERSIONINFO''';
105			ExecQuery;
106			try
107			if EOF then Exit;
108			finally
109			Close;
110			end;
111			finally
112			Free
113			end;
114
115			with TIBSQL.Create(Owner) do
116			try
117			Database := IBDatabase;
118			Transaction := IBTransaction;
119			SQL.Text := 'Select VersionNo From DBVersionInfo';
120			ExecQuery;
121			try
122			VersionNo := FieldByName('VersionNo').AsInteger;
123			finally
124			Close;
125			end;
126			finally
127			Free;
128			end;
129			finally
130			IBTransaction.Commit;
131			end;
132			end;
133
134			procedure TTest27.HandleLogMessage(Sender: TObject; Msg: string);
135			begin
136			writeln(OutFile,Msg);
137			end;
138
139			procedure TTest27.GetSharedDirectory(Sender: TObject; var SharedDataDir: string);
140			begin
141			SharedDataDir := 'resources/Test27';
142			end;
143
144			procedure TTest27.CreateObjects(Application: TTestApplication);
145			begin
146			inherited CreateObjects(Application);
147			FLocalDB := TIBCMLocalDBSupport.Create(Application);
148			FLocalDB.Database := IBDatabase;
149			FLocalDB.VendorName := 'MWA Software';
150			FLocalDB.OnGetDBVersionNo := @HandleGetDBVersionNo;
151			FLocalDB.OnLogMessage := @HandleLogMessage;
152			FLocalDB.OnGetSharedDataDir := @GetSharedDirectory;
153			end;
154
155			function TTest27.GetTestID: AnsiString;
156			begin
157			Result := aTestID;
158			end;
159
160			function TTest27.GetTestTitle: AnsiString;
161			begin
162			Result := aTestTitle;
163			end;
164
165			procedure TTest27.InitTest;
166			begin
167			IBDatabase.DatabaseName := 'nemo';
168			FLocalDB.DatabaseName := ExtractDBName(Owner.GetNewDatabaseName);
169			FLocalDB.EmptyDBArchive := 'employee.gbk';
170			FLocalDB.RequiredVersionNo := 2;
171			FLocalDB.UpgradeConfFile := 'upgrade.conf';
172			ReadOnlyTransaction;
173			end;
174
175			procedure TTest27.RunTest(CharSet: AnsiString; SQLDialect: integer);
176			begin
177			try
178			IBDatabase.Connected := true;
179			with IBQuery do
180			begin
181			AllowAutoActivateTransaction := true;
182			SQL.Text := sqlExample;
183			Active := true;
184			PrintDataSet(IBQuery);
185			end;
186			finally
187			IBDatabase.DropDatabase;
188			end;
189			end;
190
191			initialization
192			RegisterTest(TTest27);
193
194			end.
195