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