fbintf/testsuite/Test12.pas

(*
 *  Firebird Interface (fbintf) Test suite. This program is used to
 *  test the Firebird Pascal Interface and provide 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) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)

unit Test12;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}

{$codepage UTF8}
{$ENDIF}

interface

{ Test 12: Character Sets

  This test creates strings in a database with various code pages and then
  reads them back with different connection character sets. The result is
  displayed as hex strings so that the actual encoding can be checked in
  each case.
}

uses
  Classes, SysUtils, TestApplication, FBTestApp, IB;

type

  { TTest12 }

  TTest12 = class(TFBTestBase)
  private
    procedure UpdateDatabase(Attachment: IAttachment);
    procedure QueryDatabase(Attachment: IAttachment);
  public
    function TestTitle: AnsiString; override;
    procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
  end;

implementation

const
  sqlCreateTable =
    'Create Table TestData ('+
    'RowID Integer not null,'+
    'Title VarChar(32) Character Set UTF8,'+
    'Notes VarChar(64) Character Set ISO8859_1 collate FR_FR,'+
    'BlobData Blob sub_type 1 Character Set WIN1252, '+
    'BlobData2 Blob sub_type 1 Character Set UTF8, '+
    'InClear VarChar(16) Character Set OCTETS, '+
    'FixedWidth Char(4) Character set UTF8, '+
    'Primary Key(RowID)'+
    ')';

  sqlGetCharSets = 'Select RDB$CHARACTER_SET_NAME,RDB$CHARACTER_SET_ID from RDB$CHARACTER_SETS order by 2';

  sqlInsert = 'Insert into TestData(RowID,Title,Notes, BlobData,BlobData2,InClear,FixedWidth) '+
              'Values(:RowID,:Title,:Notes,:BlobData,:BlobData2,:InClear,:FixedWidth)';


{ TTest12 }

procedure TTest12.UpdateDatabase(Attachment: IAttachment);
var Transaction: ITransaction;
    Statement: IStatement;
begin
  Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);

  Statement := Attachment.PrepareWithNamedParameters(Transaction,sqlInsert);
  ParamInfo(Statement.SQLParams);
  with Statement.GetSQLParams do
  begin
    ByName('rowid').AsInteger := 1;
    {$IFDEF DCC}
    ByName('title').AsString := UTF8Encode('Blob Test ©€');
    ByName('Notes').AsString := UTF8Encode('Écoute moi');
    ByName('FixedWidth').AsString := UTF8Encode('É');
    {$ELSE}
    ByName('title').AsString := 'Blob Test ©€';
    ByName('Notes').AsString := 'Écoute moi';
    ByName('FixedWidth').AsString := 'É';
    {$ENDIF}
    ByName('BlobData').AsString := 'Some German Special Characters like ÖÄÜöäüß';
    ByName('BlobData2').AsBlob := Attachment.CreateBlob(Transaction,'TestData','BlobData').SetString('Some German Special Characters like ÖÄÜöäüß');
    ByName('InClear').AsString := #$01'Test'#$0D#$C3;
    ByName('FixedWidth').AsString := 'É';
  end;
  Statement.Execute;
end;

procedure TTest12.QueryDatabase(Attachment: IAttachment);
var Transaction: ITransaction;
    Statement: IStatement;
    ResultSet: IResultSet;
begin
  Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
  Statement := Attachment.Prepare(Transaction,'Select * from TestData');
  ReportResults(Statement);
end;

function TTest12.TestTitle: AnsiString;
begin
  Result := 'Test 12: Character Sets';
end;

procedure TTest12.RunTest(CharSet: AnsiString; SQLDialect: integer);
var DPB: IDPB;
    Attachment: IAttachment;
begin
  FHexStrings := true;
  DPB := FirebirdAPI.AllocateDPB;
  DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
  DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
  DPB.Add(isc_dpb_lc_ctype).setAsString('UTF8');
  DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
  Attachment := FirebirdAPI.CreateDatabase(Owner.GetNewDatabaseName,DPB);
  Attachment.ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable);

  UpdateDatabase(Attachment);

  writeln(OutFile,'Connection Character Set UTF8');
  {Query with UTF8}
  QueryDatabase(Attachment);
  Attachment.Disconnect;

  writeln(OutFile,'Connection Character Set NONE');
  {Query with No character set}
  DPB := FirebirdAPI.AllocateDPB;
  DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
  DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
  DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
  Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
  QueryDatabase(Attachment);
  Attachment.Disconnect;

  writeln(OutFile,'Connection Character Set WIN1252');
  {Query with WIN1252}
  DPB := FirebirdAPI.AllocateDPB;
  DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
  DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
  DPB.Add(isc_dpb_lc_ctype).setAsString('WIN1252');
  DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
  Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
  QueryDatabase(Attachment);

  Attachment.DropDatabase;

end;

initialization
  RegisterTest(TTest12);
end.

Revision:	315
Committed:	Thu Feb 25 11:56:36 2021 UTC (3 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5805 byte(s)
Log Message:	Updated for IBX 4 release
#	Content
1	(*
2	* Firebird Interface (fbintf) Test suite. This program is used to
3	* test the Firebird Pascal Interface and provide a semi-automated
4	* pass/fail check for each test.
5	*
6	* The contents of this file are subject to the Initial Developer's
7	* Public License Version 1.0 (the "License"); you may not use this
8	* file except in compliance with the License. You may obtain a copy
9	* of the License here:
10	*
11	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
12	*
13	* Software distributed under the License is distributed on an "AS
14	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
15	* implied. See the License for the specific language governing rights
16	* and limitations under the License.
17	*
18	* The Initial Developer of the Original Code is Tony Whyman.
19	*
20	* The Original Code is (C) 2016 Tony Whyman, MWA Software
21	* (http://www.mwasoftware.co.uk).
22	*
23	* All Rights Reserved.
24	*
25	* Contributor(s): ______________________________________.
26	*
27	*)
28
29	unit Test12;
30	{$IFDEF MSWINDOWS}
31	{$DEFINE WINDOWS}
32	{$ENDIF}
33
34	{$IFDEF FPC}
35	{$mode delphi}
36
37	{$codepage UTF8}
38	{$ENDIF}
39
40	interface
41
42	{ Test 12: Character Sets
43
44	This test creates strings in a database with various code pages and then
45	reads them back with different connection character sets. The result is
46	displayed as hex strings so that the actual encoding can be checked in
47	each case.
48	}
49
50	uses
51	Classes, SysUtils, TestApplication, FBTestApp, IB;
52
53	type
54
55	{ TTest12 }
56
57	TTest12 = class(TFBTestBase)
58	private
59	procedure UpdateDatabase(Attachment: IAttachment);
60	procedure QueryDatabase(Attachment: IAttachment);
61	public
62	function TestTitle: AnsiString; override;
63	procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
64	end;
65
66	implementation
67
68	const
69	sqlCreateTable =
70	'Create Table TestData ('+
71	'RowID Integer not null,'+
72	'Title VarChar(32) Character Set UTF8,'+
73	'Notes VarChar(64) Character Set ISO8859_1 collate FR_FR,'+
74	'BlobData Blob sub_type 1 Character Set WIN1252, '+
75	'BlobData2 Blob sub_type 1 Character Set UTF8, '+
76	'InClear VarChar(16) Character Set OCTETS, '+
77	'FixedWidth Char(4) Character set UTF8, '+
78	'Primary Key(RowID)'+
79	')';
80
81	sqlGetCharSets = 'Select RDB$CHARACTER_SET_NAME,RDB$CHARACTER_SET_ID from RDB$CHARACTER_SETS order by 2';
82
83	sqlInsert = 'Insert into TestData(RowID,Title,Notes, BlobData,BlobData2,InClear,FixedWidth) '+
84	'Values(:RowID,:Title,:Notes,:BlobData,:BlobData2,:InClear,:FixedWidth)';
85
86
87	{ TTest12 }
88
89	procedure TTest12.UpdateDatabase(Attachment: IAttachment);
90	var Transaction: ITransaction;
91	Statement: IStatement;
92	begin
93	Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
94
95	Statement := Attachment.PrepareWithNamedParameters(Transaction,sqlInsert);
96	ParamInfo(Statement.SQLParams);
97	with Statement.GetSQLParams do
98	begin
99	ByName('rowid').AsInteger := 1;
100	{$IFDEF DCC}
101	ByName('title').AsString := UTF8Encode('Blob Test ©€');
102	ByName('Notes').AsString := UTF8Encode('Écoute moi');
103	ByName('FixedWidth').AsString := UTF8Encode('É');
104	{$ELSE}
105	ByName('title').AsString := 'Blob Test ©€';
106	ByName('Notes').AsString := 'Écoute moi';
107	ByName('FixedWidth').AsString := 'É';
108	{$ENDIF}
109	ByName('BlobData').AsString := 'Some German Special Characters like ÖÄÜöäüß';
110	ByName('BlobData2').AsBlob := Attachment.CreateBlob(Transaction,'TestData','BlobData').SetString('Some German Special Characters like ÖÄÜöäüß');
111	ByName('InClear').AsString := #$01'Test'#$0D#$C3;
112	ByName('FixedWidth').AsString := 'É';
113	end;
114	Statement.Execute;
115	end;
116
117	procedure TTest12.QueryDatabase(Attachment: IAttachment);
118	var Transaction: ITransaction;
119	Statement: IStatement;
120	ResultSet: IResultSet;
121	begin
122	Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
123	Statement := Attachment.Prepare(Transaction,'Select * from TestData');
124	ReportResults(Statement);
125	end;
126
127	function TTest12.TestTitle: AnsiString;
128	begin
129	Result := 'Test 12: Character Sets';
130	end;
131
132	procedure TTest12.RunTest(CharSet: AnsiString; SQLDialect: integer);
133	var DPB: IDPB;
134	Attachment: IAttachment;
135	begin
136	FHexStrings := true;
137	DPB := FirebirdAPI.AllocateDPB;
138	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
139	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
140	DPB.Add(isc_dpb_lc_ctype).setAsString('UTF8');
141	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
142	Attachment := FirebirdAPI.CreateDatabase(Owner.GetNewDatabaseName,DPB);
143	Attachment.ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable);
144
145	UpdateDatabase(Attachment);
146
147	writeln(OutFile,'Connection Character Set UTF8');
148	{Query with UTF8}
149	QueryDatabase(Attachment);
150	Attachment.Disconnect;
151
152	writeln(OutFile,'Connection Character Set NONE');
153	{Query with No character set}
154	DPB := FirebirdAPI.AllocateDPB;
155	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
156	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
157	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
158	Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
159	QueryDatabase(Attachment);
160	Attachment.Disconnect;
161
162	writeln(OutFile,'Connection Character Set WIN1252');
163	{Query with WIN1252}
164	DPB := FirebirdAPI.AllocateDPB;
165	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
166	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
167	DPB.Add(isc_dpb_lc_ctype).setAsString('WIN1252');
168	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
169	Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
170	QueryDatabase(Attachment);
171
172	Attachment.DropDatabase;
173
174	end;
175
176	initialization
177	RegisterTest(TTest12);
178	end.
179