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;
  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:	341
Committed:	Wed Jul 7 13:11:53 2021 UTC (3 years, 5 months ago) by tony
Content type:	text/x-pascal
File size:	5762 byte(s)
Log Message:	Fixed Merged
#	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	end;
113	Statement.Execute;
114	end;
115
116	procedure TTest12.QueryDatabase(Attachment: IAttachment);
117	var Transaction: ITransaction;
118	Statement: IStatement;
119	ResultSet: IResultSet;
120	begin
121	Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
122	Statement := Attachment.Prepare(Transaction,'Select * from TestData');
123	ReportResults(Statement);
124	end;
125
126	function TTest12.TestTitle: AnsiString;
127	begin
128	Result := 'Test 12: Character Sets';
129	end;
130
131	procedure TTest12.RunTest(CharSet: AnsiString; SQLDialect: integer);
132	var DPB: IDPB;
133	Attachment: IAttachment;
134	begin
135	FHexStrings := true;
136	DPB := FirebirdAPI.AllocateDPB;
137	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
138	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
139	DPB.Add(isc_dpb_lc_ctype).setAsString('UTF8');
140	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
141	Attachment := FirebirdAPI.CreateDatabase(Owner.GetNewDatabaseName,DPB);
142	Attachment.ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable);
143
144	UpdateDatabase(Attachment);
145
146	writeln(OutFile,'Connection Character Set UTF8');
147	{Query with UTF8}
148	QueryDatabase(Attachment);
149	Attachment.Disconnect;
150
151	writeln(OutFile,'Connection Character Set NONE');
152	{Query with No character set}
153	DPB := FirebirdAPI.AllocateDPB;
154	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
155	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
156	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
157	Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
158	QueryDatabase(Attachment);
159	Attachment.Disconnect;
160
161	writeln(OutFile,'Connection Character Set WIN1252');
162	{Query with WIN1252}
163	DPB := FirebirdAPI.AllocateDPB;
164	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
165	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
166	DPB.Add(isc_dpb_lc_ctype).setAsString('WIN1252');
167	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
168	Attachment := FirebirdAPI.OpenDatabase(Owner.GetNewDatabaseName,DPB);
169	QueryDatabase(Attachment);
170
171	Attachment.DropDatabase;
172
173	end;
174
175	initialization
176	RegisterTest(TTest12);
177	end.
178