firebird/firebird-mirror
firebird/firebird-mirror
8
0
Fork 1
mirror of https://github.com/FirebirdSQL/firebird.git synced 2025-02-02 08:00:39 +01:00
Code Issues

Add some object pascal examples of the OO API

Browse Source
This commit is contained in:
Paul Reeves 2020-08-18 18:57:02 +02:00
parent 6f2d93efb1
commit e2842a1afd
6 changed files with 1062 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
examples/object_pascal/01.create.pas Normal file
View File

@ -0,0 +1,143 @@
{
* PROGRAM: Object oriented API samples.
* MODULE: 01.create.pas
* DESCRIPTION: A sample of creating new database and new table in it.
* Run second time (when database already exists) to see
* how FbException is caught and handled by this code.
*
* Example for the following interfaces:
* IMaster - main inteface to access all the rest
* Status - returns the status of executed command
* Provider - main interface to access DB / service
* Attachment - database attachment interface
* Transaction - transaction interface
* Util - helper calls here and there
* XpbBuilder - build various parameters blocks
*
* Run something like this to build: fpc -Fu<path-to-Firebird.pas> -Mdelphi 01.create.pas
*
* 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 at
* http://www.ibphoenix.com/main.nfs?a=ibphoenix&page=ibp_idpl.
*
* Software distributed under the License is distributed AS IS,
* WITHOUT WARRANTY OF ANY KIND, either express or implied.
* See the License for the specific language governing rights
* and limitations under the License.
*
* The Original Code was created by Alexander Peshkoff
* for the Firebird Open Source RDBMS project.
*
* Copyright (c) 2015 Alexander Peshkoff <peshkoff@mail.ru>
* and all contributors signed below.
*
* All Rights Reserved.
* Contributor(s): ______________________________________. }
Program create;
uses Sysutils, Firebird;
var
// Declare pointers to required interfaces
// Status is used to return wide error description to user
st : IStatus;
// This is main interface of firebird, and the only one
// for getting which there is special function in our API
master : IMaster;
util : IUtil;
// XpbBuilder helps to create various parameter blocks for API calls
dpb : IXpbBuilder;
// Provider is needed to start to work with database (or service)
prov : IProvider;
// Attachment and Transaction contain methods to work with
// database attachment and transaction
att : IAttachment;
tra : ITransaction;
procedure PrintError(s : IStatus);
var
maxMessage : Integer;
outMessage : PAnsiChar;
begin
maxMessage := 256;
outMessage := StrAlloc(maxMessage);
util.formatStatus(outMessage, maxMessage, s);
writeln(outMessage);
StrDispose(outMessage);
end;
begin
// Here we get access to master interface and helper utility interface
// no error return may happen - these functions always succeed
master := fb_get_master_interface;
util := master.getUtilInterface;
// status vector and main dispatcher are returned by calls to IMaster functions
// no error return may happen - these functions always succeed
st := master.getStatus;
prov := master.getDispatcher;
try
// create DPB
dpb := util.getXpbBuilder(st, IXpbBuilder.DPB, nil, 0);
dpb.insertInt(st, isc_dpb_page_size, 4 * 1024);
dpb.insertString(st, isc_dpb_user_name, 'sysdba');
dpb.insertString(st, isc_dpb_password, 'masterkey');
// create empty database
att := prov.createDatabase(st, 'fbtests.fdb', dpb.getBufferLength(st), dpb.getBuffer(st));
writeln ('Database fbtests.fdb created');
// detach from database
att.detach(st);
att := nil;
// remove unneeded any more tag from DPB
if dpb.findFirst(st, isc_dpb_page_size)
then dpb.removeCurrent(st);
// attach it once again
att := prov.attachDatabase(st, 'fbtests.fdb', dpb.getBufferLength(st), dpb.getBuffer(st));
writeln ('Re-attached database fbtests.fdb');
// start transaction
tra := att.startTransaction(st, 0, nil);
// create table
att.execute(st, tra, 0, 'create table dates_table (d1 date)', 3,
nil, nil, nil, nil); // Input parameters and output data not used
// commit transaction retaining
tra.commitRetaining(st);
writeln ('Table dates_table created');
// insert a record into dates_table
att.execute(st, tra, 0, 'insert into dates_table values (CURRENT_DATE)', 3,
nil, nil, nil, nil); // Input parameters and output data not used
// commit transaction (will close interface)
tra.commit(st);
tra := nil;
writeln ('Record inserted into dates_table');
// detach from database (will close interface)
att.detach(st);
att := nil;
dpb.dispose;
dpb := nil;
except
on e: FbException do PrintError(e.getStatus);
end;
prov.release;
end.

224
examples/object_pascal/02.update.pas Normal file
View File

@ -0,0 +1,224 @@
Program update;
{*
* PROGRAM: Object oriented API samples.
* MODULE: 02.update.cpp
* DESCRIPTION: Run once prepared statement with parameters
* a few times, committing transaction after each run.
* Learns how to prepare statement, manually define parameters
* for it, execute that statement with different parameters
* and perform non-default error processing.
*
* Example for the following interfaces:
* IAttachment - database attachment
* ITransaction - transaction
* IStatement - SQL statement execution
* IMessageMetadata - describe input and output data format
* IMetadataBuilder - tool to modify/create metadata
* IStatus - return state holder
*
* Note that all updates are rolled back in this version. (see *** later)
*
* Run something like this to build the program :
*
* fpc -Fu./common -Fu/opt/firebird/include/firebird -FUlib -oupdate 02.update.pas
*
* 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 at
* https://www.ibphoenix.com/about/firebird/idpl.
*
* Software distributed under the License is distributed AS IS,
* WITHOUT WARRANTY OF ANY KIND, either express or implied.
* See the License for the specific language governing rights
* and limitations under the License.
*
* The Original Code was created by Paul Reeves
* for the Firebird Open Source RDBMS project.
*
* All Rights Reserved.
* Contributor(s): ______________________________________.
*
*}
{$mode Delphi}{$H+}
Uses
SysUtils,
Firebird;
Type
Buffer = String [255];
Var
// master and status are required for all access to the API.
// This is main interface of firebird, and the only one
// for getting which there is special function in our API
master: IMaster;
// Status is used to return error description to user
status: IStatus;
// Provider is needed to start to work with database (or service)
prov: IProvider;
// declare pointers to required interfaces
att: IAttachment;
tra: ITransaction;
// Interface executes prepared SQL statement
stmt: IStatement;
// Interfaces provides access to format of data in messages
meta: IMessageMetadata;
// Interface makes it possible to change format of data or define it yourself
builder: IMetadataBuilder;
Dept_Data: Array[0..4] Of String = ( '622', '100', '116', '900', '0' );
Percent_data: Array[0..4] Of Double = ( 0.05, 1.00, 0.075, 0.10, 0 );
i: Integer;
InputBuffer: Buffer;
len: Integer;
PPercent_inc: PChar;
PDept_no: PChar;
Const
UpdateString = 'UPDATE department SET budget = ? * budget + budget WHERE dept_no = ?';
SQL_DIALECT_V6 = 3;
SQL_DIALECT_CURRENT = SQL_DIALECT_V6;
SQL_TEXT = 452; // CHAR
SQL_DOUBLE = 480; // DOUBLE PRECISION
Procedure PrintError( AMaster: IMaster; AStatus: IStatus );
Var
maxMessage: Integer;
outMessage: PAnsiChar;
Begin
maxMessage := 256;
outMessage := StrAlloc( maxMessage );
AMaster.getUtilInterface.formatStatus( outMessage, maxMessage, AStatus );
writeln( outMessage );
StrDispose( outMessage );
End;
// Get the department and percent parameters for an example to run.
Begin
master := fb_get_master_interface;
status := master.getStatus;
Try
// the main dispatcher is returned by a call to IMaster
// no errors can occur - this function will always succeed
prov := master.getDispatcher;
// We assume that ISC_USER and ISC_PASSWORD env vars are set. Otherwise,
// see code in 01.create for an example of setting the un/pw via the dpb.
att := prov.attachDatabase( status, 'employee', 0, nil );
writeln( 'Attached to database employee.fdb' );
// start transaction
tra := att.startTransaction( status, 0, nil );
// prepare statement
stmt := att.prepare( status, tra, 0, UpdateString, SQL_DIALECT_CURRENT, 0 );
// build metadata
// IMaster creates empty new metadata in builder
builder := master.getMetadataBuilder( status, 2 );
// set required info on fields
builder.setType( status, 0, SQL_DOUBLE + 1 );
builder.setType( status, 1, SQL_TEXT + 1 );
builder.setLength( status, 1, 3 );
// IMetadata should be ready
meta := builder.getMetadata( status );
// no need for builder any more
builder.Release( );
builder := nil;
len := meta.getMessageLength( status );
If ( len > sizeof( InputBuffer ) ) Then
Raise Exception.Create( 'Input message length too big - cannot continue' )
Else
FillChar( InputBuffer, SizeOf( InputBuffer ), 0 );
i := meta.getNullOffset( status, 0 );
InputBuffer[i] := Char( 0 );
i := meta.getNullOffset( status, 1 );
InputBuffer[i] := Char( 0 );
Try
// locations of parameters in input message
PPercent_inc := PChar( @InputBuffer [meta.getOffset( status, 0 )] );
PDept_no := PChar( @InputBuffer [meta.getOffset( status, 1 )] );
For i := 0 To length( Dept_Data ) - 1 Do Begin
If ( Dept_Data [i] = '0' ) Or ( Percent_data [i] = 0 ) Then
break;
StrPCopy( PPercent_inc, Percent_data [i].ToString );
StrPCopy( PDept_no, Dept_Data [i] );
WriteLn( 'Increasing budget for department: ' + PDept_no + ' by ' + PPercent_inc + ' percent.' );
Try
stmt.Execute( status, tra, meta, @InputBuffer, nil, nil );
// Save/Cancel each department's update independently.
// *** Change to commitRetaining() to see changes
// *** tra.commitRetaining(status);
tra.rollbackRetaining( status );
Except
on E: FBException Do Begin
PrintError( master, status );
tra.rollbackRetaining( status );
End;
End;
End;
stmt.Free( status );
stmt := nil;
meta.Release;
meta := nil;
tra.commit( status );
tra := nil;
att.detach( status );
att := nil;
Except
on E: FBException Do Begin
PrintError( master, status );
tra.rollbackRetaining( status );
End;
on E: Exception Do
WriteLn( E.Message );
End;
Finally
If assigned( meta ) Then
meta.Release;
If assigned( builder ) Then
builder.Release;
If assigned( stmt ) Then
stmt.Release;
If assigned( tra ) Then
tra.Release;
If assigned( att ) Then
att.Release;
prov.Release;
status.dispose;
End;
End.

324
examples/object_pascal/03.select.pas Normal file
View File

@ -0,0 +1,324 @@
Program select;
{
* PROGRAM: Object oriented API samples.
* MODULE: 03.select.pas
* DESCRIPTION:
* A sample of running SELECT statement without parameters.
* Prints string fields in a table, coercing VARCHAR to CHAR.
* Learns how to coerce output data in prepared statement
* and execute it.
*
* Example for the following interfaces:
*
* IStatement - SQL statement execution
* IMessageMetadata - describe input and output data format
* IResultSet - fetch data returned by statement after execution
*
* Run something like this to build the program :
*
* fpc -Fu./common -Fu/opt/firebird/include/firebird -FUlib 03.select.pas
*
*
* 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 at
* https://www.ibphoenix.com/about/firebird/idpl.
*
* Software distributed under the License is distributed AS IS,
* WITHOUT WARRANTY OF ANY KIND, either express or implied.
* See the License for the specific language governing rights
* and limitations under the License.
*
* The Original Code was created by Paul Reeves
* for the Firebird Open Source RDBMS project.
* Most of the code for GetOutput was taken from Denis
* Simonov's UDR-Book project.
*
* Copyright (c) 2020 Paul Reeves <preeves@ibphoenix.com>
* and all contributors signed below.
*
* All Rights Reserved.
* Contributor(s): ______________________________________. }
{$mode Delphi}{$H+}
Uses {$IFDEF UNIX} {$IFDEF UseCThreads}
cthreads
, {$ENDIF} {$ENDIF}
SysUtils
, Firebird
, strutils
, FbCharsets
;
// Record to store received metadata
Type
TField = Record
fieldname: String;
fieldtype: Cardinal;
fieldlength: Integer;
offset: Integer;
sqlnullind: Wordbool;
charset: TFBCharSet;
charLength: Integer;
fieldvalue: String;
End;
Var
// master and status are required for all access to the API.
// This is main interface of firebird, and the only one
// for getting which there is special function in our API
master: IMaster;
// Status is used to return error descriptions to user
status: IStatus;
// Provides some miscellaneous utilities.
util: IUtil;
// Provider is needed to start to work with database (or service)
prov: IProvider;
// Attachment and Transaction contain methods to work with
// database attachment and transaction
att: IAttachment;
tra: ITransaction;
tpb: IXpbBuilder;
// to prepare an sql statement
stmt: IStatement;
// We geain access to the result set with a cursor
curs: IResultSet;
// Retrieve info about metadata of a statement
meta: IMessageMetadata;
builder: IMetadataBuilder;
// Store the meta data of each field in the result set
fields: Array Of TField;
// Store the titles of each field in the result set
title: String = '';
// msg is a pointer to each row in the result set.
msg: Pointer;
msgLen: Cardinal;
counter: Integer;
Const
// Firebird types
SQL_VARYING = 448; // VARCHAR
SQL_TEXT = 452; // CHAR
Procedure PrintError(AMaster: IMaster; AStatus: IStatus);
Var
maxMessage: Integer;
outMessage: PAnsiChar;
Begin
maxMessage := 256;
outMessage := StrAlloc(maxMessage);
AMaster.getUtilInterface.formatStatus(outMessage, maxMessage, AStatus);
writeln(outMessage);
StrDispose(outMessage);
End;
Function GetOutput(AStatus: IStatus; ABuffer: PByte; AMeta: IMessageMetadata; AUtil: IUtil;
AFieldsArray: Array Of TField): UnicodeString;
Var
i: Integer;
NullFlag: Wordbool;
pData: PByte;
CharBuffer: TBytes;
StringValue: UnicodeString;
current_field: TField;
Begin
Result := '';
For i := 0 To length(AFieldsArray) - 1 Do Begin
current_field := AfieldsArray[i];
With current_field Do Begin
NullFlag := PWordBool(ABuffer + AMeta.getNullOffset(AStatus, i))^;
If NullFlag Then Begin
StringValue := 'NULL';
continue;
End;
// get a pointer to the field data
pData := ABuffer + AMeta.getOffset(AStatus, i);
pData := ABuffer + offset;
Case fieldType Of
SQL_VARYING:
Begin
SetLength(CharBuffer, fieldLength);
// For VARCHAR, the first 2 bytes are the length
charLength := PSmallint(pData)^;
// For VARCHAR, the first 2 bytes are the length in bytes
// so we copy it to the buffer starting at 3 bytes
Move((pData + 2)^, CharBuffer[0], fieldLength);
StringValue := charset.GetString(CharBuffer, 0, charLength);
End;
Else
StringValue := ' Fieldtype not handled.';
End; // case fieldType of
If Result = '' Then
Result := Result + UnicodeString(PadRight(UTF8Encode(StringValue), fieldLength))
Else
Result := Result + ' ' + UnicodeString(PadRight(UTF8Encode(StringValue), fieldLength));
End; // end with current_field
End; // for i := 0 to length(AFieldsArray) - 1 do begin
End; // function GetOutput
Begin
master := fb_get_master_interface;
status := master.getStatus;
// Here we get access to the helper utility interfaces
// no errors can occur - this function will always succeed
util := master.getUtilInterface;
// the main dispatcher is returned by a call to IMaster
// no errors can occur - this function will always succeed
prov := master.getDispatcher;
Try
Try
// attach to employee db
// We assume that ISC_USER and ISC_PASSWORD env vars are set. Otherwise,
// see code in 01.create for an example of setting the un/pw via the dpb.
att := prov.attachDatabase(status, 'employee', 0, nil);
writeln('Attached to database employee.fdb');
// start read only transaction
tpb := util.getXpbBuilder(status, IXpbBuilder.TPB, nil, 0);
tpb.insertTag(status, isc_tpb_read_committed);
tpb.insertTag(status, isc_tpb_no_rec_version);
tpb.insertTag(status, isc_tpb_wait);
tpb.insertTag(status, isc_tpb_read);
// start transaction
tra := att.startTransaction(status, 0, nil);
// prepare statement
stmt := att.prepare(status, tra, 0, 'Select last_name, first_name, phone_ext from phone_list ' +
'where location = ''Monterey'' order by last_name, first_name', 3,
IStatement.PREPARE_PREFETCH_METADATA);
// get list of columns
meta := stmt.getOutputMetadata(status);
builder := meta.getBuilder(status);
SetLength(fields, meta.getCount(status));
// parse columns list & coerce datatype(s)
For counter := 0 To length(fields) - 1 Do Begin
If ((meta.getType(status, counter) = (SQL_VARYING Or SQL_TEXT))) Then
builder.setType(status, counter, SQL_TEXT);
fields[counter].fieldname := meta.getField(status, counter);
End;
// release automatically created metadata
// metadata is not database object, therefore no specific call to close it
meta.Release;
// get metadata with coerced datatypes
meta := builder.getMetadata(status);
// builder is no longer needed
builder.Release;
builder := nil;
// now get field info
For counter := 0 To length(fields) - 1 Do Begin
If fields[counter].fieldname <> '' Then Begin
fields[counter].fieldlength := meta.getLength(status, counter);
fields[counter].offset := meta.getOffset(status, counter);
fields[counter].fieldType := meta.getType(status, counter) And Not 1;
Case fields[counter].fieldType Of
SQL_TEXT, SQL_VARYING:
fields[counter].charset := TFBCharSet(meta.getCharSet(status, counter));
Else
;
End;
// Set the title line for later use.
If title = '' Then
title := title + fields[counter].fieldname.PadRight(fields[counter].fieldlength)
Else
title := title + ' ' + fields[counter].fieldname.PadRight(fields[counter].fieldlength);
End;
End;
// open cursor
curs := stmt.openCursor(status, tra, nil, nil, meta, 0);
// allocate output buffer
msgLen := meta.getMessageLength(status);
msg := AllocMem(msgLen);
counter := 0;
While curs.fetchNext(status, msg) = IStatus.RESULT_OK Do Begin
If ((counter Mod 10) = 0) Then Begin
writeln('');
writeln(title);
End;
Inc(counter);
WriteLn(GetOutput(status, msg, meta, util, fields));
End;
// What is correct way to close and release?
// close interfaces
curs.Close(status);
stmt.Free(status);
meta.Release();
tra.commit(status);
att.detach(status);
Except
on e: FbException Do
PrintError(master, e.getStatus);
End;
Finally
If assigned(meta) Then
meta.Release;
If assigned(builder) Then
builder.Release;
If assigned(curs) Then
curs.Release;
If assigned(stmt) Then
stmt.Release;
If assigned(tra) Then
tra.Release;
If assigned(att) Then
att.Release;
If assigned(tpb) Then
tpb.dispose;
prov.Release;
status.dispose;
End;
End.

48
examples/object_pascal/Readme.md Normal file
View File

@ -0,0 +1,48 @@
Object Pascal Examples for Firebird
===================================
The aim of these examples is to copy as closely as possible the equivalent
C++ examples. The primary intention is to demonstrate how to make calls to
the new Firebird OO API. For this reason they should not be considered
examples of best practice.
Project files for Delphi and Lazarus are not supplied. Project files take
up a lot of space and hide the simplicity of the sample programs.
Each sample file can easily be converted into a project and the way to do
this is explained below.
Requirements
------------
The examples have been tested with the Free Pascal compiler on linux.
The code should work with Delphi but has not been tested.
Building and running the examples
---------------------------------
Just type make at the command line.
If you do not have a standard firebird installation be sure to change
the variables at the top of the make file.
Opening the code in Lazarus or Delphi
-------------------------------------
Each example is a stand-alone program. To open and run it in your favourite
Object Pascal IDE you just have to convert the example to a project. In Lazarus
you would do the following to create a project from 03.select.pas:
- Copy 03.select.pas and rename it select.lpr
- Open select.lpr as a project
- When prompted choose 'Simple Program' as the project template
- Go into Project options and add the following paths:
/opt/firebird/include/Firebird
common
You can then compile and run the example through the debugger.

257
examples/object_pascal/common/FbCharsets.pas Normal file
View File

@ -0,0 +1,257 @@
{
* PROGRAM: UDR samples.
* MODULE: FbCharsets.pas
* DESCRIPTION: Charset helpers.
*
* 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 at
* https://www.ibphoenix.com/about/firebird/idpl.
*
* Software distributed under the License is distributed AS IS,
* WITHOUT WARRANTY OF ANY KIND, either express or implied.
* See the License for the specific language governing rights
* and limitations under the License.
*
* The Original Code was created by Simonov Denis
* for the book Writing UDR Firebird in Pascal.
*
* Copyright (c) 2018 Simonov Denis <sim-mail@list.ru>
* and all contributors signed below.
*
* All Rights Reserved.
* Contributor(s): ______________________________________. }
unit FbCharsets;
{$IFDEF MSWINDOWS}
{$DEFINE WINDOWS}
{$ENDIF}
{$IFDEF FPC}
{$mode delphi}
{$ENDIF}
interface
uses
Classes, SysUtils {$IFDEF WINDOWS}, windows {$ENDIF};
type
// Firebird character sets
TFBCharSet = (
CS_NONE = 0, // No Character Set
CS_BINARY = 1, // BINARY BYTES
CS_ASCII = 2, // ASCII
CS_UNICODE_FSS = 3, // UNICODE in FSS format
CS_UTF8 = 4, // UTF-8
CS_SJIS = 5, // SJIS
CS_EUCJ = 6, // EUC-J
CS_JIS_0208 = 7 , // JIS 0208; 1990
CS_UNICODE_UCS2 = 8 , // UNICODE v 1.10
CS_DOS_737 = 9,
CS_DOS_437 = 10 , // DOS CP 437
CS_DOS_850 = 11 , // DOS CP 850
CS_DOS_865 = 12 , // DOS CP 865
CS_DOS_860 = 13 , // DOS CP 860
CS_DOS_863 = 14 , // DOS CP 863
CS_DOS_775 = 15,
CS_DOS_858 = 16,
CS_DOS_862 = 17,
CS_DOS_864 = 18,
CS_NEXT = 19, // NeXTSTEP OS native charset
CS_ISO8859_1 = 21, // ISO-8859.1
CS_ISO8859_2 = 22, // ISO-8859.2
CS_ISO8859_3 = 23, // ISO-8859.3
CS_ISO8859_4 = 34, // ISO-8859.4
CS_ISO8859_5 = 35, // ISO-8859.5
CS_ISO8859_6 = 36, // ISO-8859.6
CS_ISO8859_7 = 37, // ISO-8859.7
CS_ISO8859_8 = 38, // ISO-8859.8
CS_ISO8859_9 = 39, // ISO-8859.9
CS_ISO8859_13 = 40, // ISO-8859.13
CS_KSC5601 = 44, // KOREAN STANDARD 5601
CS_DOS_852 = 45 , // DOS CP 852
CS_DOS_857 = 46 , // DOS CP 857
CS_DOS_861 = 47 , // DOS CP 861
CS_DOS_866 = 48,
CS_DOS_869 = 49,
CS_CYRL = 50 ,
CS_WIN1250 = 51, // Windows cp 1250
CS_WIN1251 = 52, // Windows cp 1251
CS_WIN1252 = 53, // Windows cp 1252
CS_WIN1253 = 54, // Windows cp 1253
CS_WIN1254 = 55, // Windows cp 1254
CS_BIG5 = 56, // Big Five unicode cs
CS_GB2312 = 57, // GB 2312-80 cs
CS_WIN1255 = 58, // Windows cp 1255
CS_WIN1256 = 59, // Windows cp 1256
CS_WIN1257 = 60, // Windows cp 1257
CS_UTF16 = 61, // UTF-16
CS_UTF32 = 62, // UTF-32
CS_KOI8R = 63, // Russian KOI8R
CS_KOI8U = 64, // Ukrainian KOI8U
CS_WIN1258 = 65, // Windows cp 1258
CS_TIS620 = 66 , // TIS620
CS_GBK = 67, // GBK
CS_CP943C = 68, // CP943C
CS_GB18030 = 69 // GB18030
);
// Firebird character set mappig to code pages
TCharsetMap = record
CharsetID: Integer;
CharSetName: AnsiString;
CharSetWidth: Word;
CodePage: Integer;
end;
{ TFbCharsetHelper }
TFbCharsetHelper = record helper for TFBCharSet
function GetCharset : TCharsetMap;
function GetCodePage: Integer;
function GetCharWidth: Word;
function GetCharSetName: string;
function GetEncoding : TEncoding;
function GetString(const Bytes: TBytes; ByteIndex, ByteCount: Integer): UnicodeString;
end;
implementation
const
CharSetMap: array [0 .. 69] of TCharsetMap = (
(CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP),
(CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE),
(CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: {CP_ASCII} CP_ACP),
(CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8),
(CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8),
(CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932),
(CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932),
(CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737),
(CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437),
(CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850),
(CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865),
(CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860),
(CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863),
(CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775),
(CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858),
(CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862),
(CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864),
(CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE),
(CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591),
(CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592),
(CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593),
(CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 25; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 26; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 27; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 28; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 29; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 30; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 31; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 32; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 33; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 34; CharSetName: 'ISO8859_4'; CharSetWidth: 1; CodePage: 28594),
(CharsetID: 35; CharSetName: 'ISO8859_5'; CharSetWidth: 1; CodePage: 28595),
(CharsetID: 36; CharSetName: 'ISO8859_6'; CharSetWidth: 1; CodePage: 28596),
(CharsetID: 37; CharSetName: 'ISO8859_7'; CharSetWidth: 1; CodePage: 28597),
(CharsetID: 38; CharSetName: 'ISO8859_8'; CharSetWidth: 1; CodePage: 28598),
(CharsetID: 39; CharSetName: 'ISO8859_9'; CharSetWidth: 1; CodePage: 28599),
(CharsetID: 40; CharSetName: 'ISO8859_13'; CharSetWidth: 1; CodePage: 28603),
(CharsetID: 41; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 42; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 43; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 44; CharSetName: 'KSC_5601'; CharSetWidth: 2; CodePage: 949),
(CharsetID: 45; CharSetName: 'DOS852'; CharSetWidth: 1; CodePage: 852),
(CharsetID: 46; CharSetName: 'DOS857'; CharSetWidth: 1; CodePage: 857),
(CharsetID: 47; CharSetName: 'DOS861'; CharSetWidth: 1; CodePage: 861),
(CharsetID: 48; CharSetName: 'DOS866'; CharSetWidth: 1; CodePage: 866),
(CharsetID: 49; CharSetName: 'DOS869'; CharSetWidth: 1; CodePage: 869),
(CharsetID: 50; CharSetName: 'CYRL'; CharSetWidth: 1; CodePage: 1251),
(CharsetID: 51; CharSetName: 'WIN1250'; CharSetWidth: 1; CodePage: 1250),
(CharsetID: 52; CharSetName: 'WIN1251'; CharSetWidth: 1; CodePage: 1251),
(CharsetID: 53; CharSetName: 'WIN1252'; CharSetWidth: 1; CodePage: 1252),
(CharsetID: 54; CharSetName: 'WIN1253'; CharSetWidth: 1; CodePage: 1253),
(CharsetID: 55; CharSetName: 'WIN1254'; CharSetWidth: 1; CodePage: 1254),
(CharsetID: 56; CharSetName: 'BIG_5'; CharSetWidth: 2; CodePage: 950),
(CharsetID: 57; CharSetName: 'GB_2312'; CharSetWidth: 2; CodePage: 936),
(CharsetID: 58; CharSetName: 'WIN1255'; CharSetWidth: 1; CodePage: 1255),
(CharsetID: 59; CharSetName: 'WIN1256'; CharSetWidth: 1; CodePage: 1256),
(CharsetID: 60; CharSetName: 'WIN1257'; CharSetWidth: 1; CodePage: 1257),
(CharsetID: 61; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 62; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE),
(CharsetID: 63; CharSetName: 'KOI8R'; CharSetWidth: 1; CodePage: 20866),
(CharsetID: 64; CharSetName: 'KOI8U'; CharSetWidth: 1; CodePage: 21866),
(CharsetID: 65; CharSetName: 'WIN1258'; CharSetWidth: 1; CodePage: 1258),
(CharsetID: 66; CharSetName: 'TIS620'; CharSetWidth: 1; CodePage: 874),
(CharsetID: 67; CharSetName: 'GBK'; CharSetWidth: 2; CodePage: 936),
(CharsetID: 68; CharSetName: 'CP943C'; CharSetWidth: 2; CodePage: 943),
(CharsetID: 69; CharSetName: 'GB18030'; CharSetWidth: 4; CodePage: 54936));
{ TFbCharset }
function TFbCharsetHelper.GetCharset(): TCharsetMap;
begin
Result := CharSetMap[Integer(Self)];
end;
function TFbCharsetHelper.GetCodePage(): Integer;
begin
Result := CharSetMap[Integer(Self)].CodePage;
end;
function TFbCharsetHelper.GetCharWidth(): Word;
begin
Result := CharSetMap[Integer(Self)].CharSetWidth;
end;
function TFbCharsetHelper.GetCharSetName(): string;
begin
Result := CharSetMap[Integer(Self)].CharSetName;
end;
function TFbCharsetHelper.GetEncoding (): TEncoding;
begin
Result := TEncoding.GetEncoding(CharSetMap[Integer(Self)].CodePage);
end;
function TFbCharsetHelper.GetString(
const Bytes: TBytes; ByteIndex, ByteCount: Integer): UnicodeString;
var
xEncoding: TEncoding;
begin
xEncoding := GetEncoding();
try
Result := xEncoding.GetString(Bytes, ByteIndex, ByteCount);
finally
xEncoding.Free;
end;
end;
end.

66
examples/object_pascal/makefile Normal file
View File

@ -0,0 +1,66 @@
#
# 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 at
# https://www.ibphoenix.com/about/firebird/idpl.
#
# Software distributed under the License is distributed AS IS,
# WITHOUT WARRANTY OF ANY KIND, either express or implied.
# See the License for the specific language governing rights
# and limitations under the License.
#
# The Original Code was created by Paul Reeves for IBPhoenix
# and the Firebird Open Source RDBMS project.
#
# Copyright (c) 2020 Paul Reeves and all contributors signed below.
#
# All Rights Reserved.
# Contributor(s): ______________________________________.
#
# -----------------------------------------------------------------------
# Firebird Installation Directory
#
# Change this definition to point to your Firebird installation directory
# -----------------------------------------------------------------------
FIREBIRD = /opt/firebird
INCLUDE_FB = $(FIREBIRD)/include/firebird
FBCLIENT = $(FIREBIRD)/lib/libfbclient.so
# Directory to store compiled unit files
UNITBINDIR = lib
# ---------------------------------------------------------------------
# General Compiler and linker Defines for Free Pascal
# ---------------------------------------------------------------------
FPC = fpc
FPCFLAGS = -g -Fucommon -Fu$(INCLUDE_FB) -FU$(UNITBINDIR) -Mdelphi -FE.
RM = rm -f
OBJECTS = $(UNITBINDIR)/*
OUTBIN = 01.create 02.update 03.select
# To Do...
# 04.print_table 05.user_metadata.cpp 06.fb_message 07.blob 08.events 09.service 10.backup 11.batch 12.batch_isc 13.null_pk
.PHONY: clean all
.SUFFIXES: .pas
.pas:
-mkdir $(UNITBINDIR)
$(FPC) $(FPCFLAGS) $<
all: $(OUTBIN)
01.create: 01.create.pas
02.update: 02.update.pas
03.select: 03.select.pas
# clean up
clean:
$(RM) $(OBJECTS) $(OUTBIN) fbtests.fdb
-rm -d $(UNITBINDIR)