2011. május 7., szombat
Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi
Problem/Question/Abstract:
Have you ever tried to create a stored procedure on an SQL Server?
What if the functionality you wish to incorporate is not inside the SQL but in your Delphi project? Microsoft provides ODS (Open Data Services) which is an API to help you create such functionality by adding DLL's to your SQL Server that contain Extended Stored Procedures.
This is how you do it....
Answer:
As a special bonus, this article also is a simple solution to encrypting your data inside SQL Server using Extended Stored Procedures.
What do we need?
opends60.dll (from a full installation with developer tools of MSSQL or MSDE)
MsOdsApi.pas (Header file to use opends60.dll) (included at the end of the article)
A Local SQL Server for testing (MSDE will do fine).
NOTE: For cryptography I used the components found under MIT license here:
http://www.cityinthesky.co.uk/cryptography.html
Steps:
Create a new DLL.
Create a unit and in the uses clause add the MsOdsApi unit.
In the Library file just under ther Uses clause add Exports and the names of the functions to export:
library MyEncryptDll;
uses
SysUtils,
Classes,
Unit1 in 'Unit1.pas';
exports
xp_DoEncrypt,
xp_DoDecrypt;
begin
end.
4. In the Unit file just under the Uses clause add your function reference:
function xp_DoEncrypt(pSrvProc: SRV_PROC): Integer; cdecl;
function xp_DoDecrypt(pSrvProc: SRV_PROC): Integer; cdecl;
NOTES: cdecl is required for ODS to be able to call your functions. SRV_PROC is a handle to the stored procedure information.
5. The code of the DoEncrypt is this: (DoDecrypt is exactly the same just with a DecryptString(s) call.
function xp_Encrypt(pSrvProc: SRV_PROC): Integer;cdecl;
var
i, sz: Integer;
bType: Byte;
fNull: Bool;
cbMaxLen, cbActualLen: ULONG;
myData,myanswer,myKey:array [0..255] of char;
FDCP_3des: TDCP_3des;
s:string;
ps:pchar;
begin
for i:=0 to 255 do
begin
myData[i]:=#0;
myanswer[i]:=#0;
myKey[i]:=#0;
end;
if srv_rpcparams(pSrvProc) = 2 then // Check if input parameters are present...
begin
srv_paraminfo(pSrvProc, 1, @bType, // Let's use 1st input parameter!
@cbMaxLen, @cbActualLen, // NOTE: We assume here what only 2 parameters
@myData[0], @fNull); //of type String can be passed!!!
bType:=SRVVARCHAR;
srv_paraminfo(pSrvProc, 2, @bType,
@cbMaxLen, @cbActualLen,
@myKey[0], @fNull);
end
else
MyData := ''; // No input parameters? Use default value instead.
//ENCRYPTION CODE BELOW YOU CAN DO WHATEVER YOU NEED HERE WITH THE PARAMETER VALUES
FDCP_3des:=TDCP_3des.Create(nil);
FDCP_3des.BlockSize:=64;
FDCP_3des.Algorithm:='3DES';
FDCP_3des.CipherMode:=cmCBC;
FDCP_3des.Id:=24;
FDCP_3des.MaxKeySize:=192;
FDCP_3des.InitStr(myKey,TDCP_sha1);
s:=string(mydata);
strpcopy(myAnswer,FDCP_3des.EncryptString(s));
FDCP_3des.Burn;
// SETTING UP ANSWER VALUES TO PCHAR AND GETTING SIZE
s:=string(myAnswer);
sz:=length(s);
ps:=allocmem(sz);
ps:=pchar(s);
// Describe columns
// (Actually, you are doing that for every datatype and every column you want to return).
srv_describe(pSrvProc,1 , 'Value', SRV_NULLTERM,
SRVVARCHAR, sz,
SRVVARCHAR, sz, nil);
// Begin output...
srv_setcoldata(pSrvProc, 1, @ps[0]);
srv_sendrow(pSrvProc); // Send the row.
srv_senddone(pSrvProc, // Finally send data back to SQL Server:
(SRV_DONE_COUNT or SRV_DONE_MORE), 0, 1); // send results completion message.
// FREEING ENCRYPTION COMPONENT
FreeAndNil(FDCP_3des);
result := 1; // Report success (1 = SUCCEED, 0 = FAIL)
end;
NOTE: There are a number of things you can do with ODS. This is just an example for Delphi. You can read the ODS help in MSDN and do even more.
6. Testing and Debugging:
A) Install SQL 7.0/2000 on your workstation (or install Delphi on workstation where SQL Server is installed).
B) Register your Xp on SQL Server.
NOTES:
Register Xp like this:
use master
go
sp_addextendedproc 'xp_DoEncrypt', 'MyEncryptDll.dll'
go
sp_addextendedproc 'xp_DoDecrypt', 'MyEncryptDll.dll'
go
Unregister Xp like this:
use master
go
sp_dropextendedproc 'xp_DoEncrypt'
go
sp_dropextendedproc 'xp_DoDecrypt'
go
Unlock DLL in case it still being used by SQL like this:
use master
go
DBCC MyEncryptDll(FREE)
go
C) In Delphi, select from main menu Run -> Run Parameters.
In the Host Application field, specify a pathname to your SQL Server executable (sqlservr.exe). For SQL 7.0, this is enough. For SQL 2000, in the Parameters field specify a command line parameter "-sYOUR_SQL_NAME", where YOUR_SQL_NAME is the name assigned to your SQL Server during the installation.
Set breakpoints in your Delphi code and run project. SQL Server will start as a console application.
D) You can execute your Xp from Query Analyzer and trace code in Delphi.
NOTE:
Executing an extended stored procedure is done like this:
exec master..xp_DoEncrypt 'ValueToEncrypt','KeyValue'
go
E) To exit application, press Ctrl+Pause in the SQL Server console window.
-------------------------------------------------------
End of article. Bellow follows a unit required for ODS.
-------------------------------------------------------
MsOdsApi.pas (Copy from line below)
unit MsOdsApi;
//------------------------------------------------------------
// Open Data Services header file: srv.h
// Copyright (c) 1989, 1990, 1991, 1997 by Microsoft Corp.
//
// Avoid double inclusion
//#ifndef _ODS_SRV_H_
// _ODS_SRV_H_
//#include "windows.h"
// ODS uses pack(4) on all CPU types
//#pragma pack(4)
//#ifdef __cplusplus
//extern "C" {
//#endif
// define model
//#if !defined( FAR )
// FAR far
//#endif
//------------------------------------------------------------
// Formats of data types
//#if !defined(DBTYPEDEFS) // Do not conflict with DBLIB definitions
//#if !defined(MAXNUMERICLEN) // Do not conflict with ODBC definitions
// DBTYPEDEFS
interface
uses
Windows;
type
DBBOOL = Byte;
DBBYTE = Byte;
DBTINYINT = Byte;
DBSMALLINT = Smallint;
DBUSMALLINT = Word;
DBINT = Longint;
DBCHAR = Char;
PDBCHAR = ^DBCHAR;
DBBINARY = Byte;
DBBIT = Byte;
DBFLT8 = Double;
srv_datetime = record
// Format for SRVDATETIME
dtdays: Longint; // number of days since 1/1/1900
dttime: Longword; // number 300th second since mid
end;
DBDATETIME = srv_datetime;
srv_dbdatetime4 = record
// Format for SRVDATETIM4
numdays: Word; // number of days since 1/1/1900
nummins: Word; // number of minutes sicne midnight
end;
DBDATETIM4 = srv_dbdatetime4;
srv_money = record
// Format for SRVMONEY
mnyhigh: Longint;
mnylow : Longword;
end;
DBMONEY = srv_money;
DBFLT4 = Double;
DBMONEY4 = Longint;
const
MAXNUMERICDIG = 38;
DEFAULTPRECISION = 19; // 18
DEFAULTSCALE = 0;
MAXNUMERICLEN = 16;
type
srv_dbnumeric = packed record
// Format for SRVNUMERIC,SRVNUMERICN,SRVDECIMAL,SRVDECIMALN
precision: Byte;
scale : Byte;
sign : Byte; // 1 = Positive, 0 = Negative
val : array [0..MAXNUMERICLEN-1] of Byte; // Padded little-endian value
end;
DBNUMERIC = srv_dbnumeric;
DBDECIMAL = DBNUMERIC;
//#endif // #if !defined(MAXNUMERICLEN)
//#endif // #if !defined( DBTYPEDEFS )
//------------------------------------------------------------
// Constants used by APIs
// Type Tokens
const
SRV_TDS_NULL = $1f;
SRV_TDS_TEXT = $23;
SRV_TDS_GUID = $24;
SRV_TDS_VARBINARY = $25;
SRV_TDS_INTN = $26;
SRV_TDS_VARCHAR = $27;
SRV_TDS_BINARY = $2d;
SRV_TDS_IMAGE = $22;
SRV_TDS_CHAR = $2f;
SRV_TDS_INT1 = $30;
SRV_TDS_BIT = $32;
SRV_TDS_INT2 = $34;
SRV_TDS_DECIMAL = $37;
SRV_TDS_INT4 = $38;
SRV_TDS_DATETIM4 = $3a;
SRV_TDS_FLT4 = $3b;
SRV_TDS_MONEY = $3c;
SRV_TDS_DATETIME = $3d;
SRV_TDS_FLT8 = $3e;
SRV_TDS_NUMERIC = $3f;
SRV_TDS_NTEXT = $63;
SRV_TDS_BITN = $68;
SRV_TDS_DECIMALN = $6a;
SRV_TDS_NUMERICN = $6c;
SRV_TDS_FLTN = $6d;
SRV_TDS_MONEYN = $6e;
SRV_TDS_DATETIMN = $6f;
SRV_TDS_MONEY4 = $7a;
SRV_TDS_INT8 = $7f; // SQL 2000 and later
SRV_TDS_BIGVARBINARY = $A5;
SRV_TDS_BIGVARCHAR = $A7;
SRV_TDS_BIGBINARY = $AD;
SRV_TDS_BIGCHAR = $AF;
SRV_TDS_NVARCHAR = $e7;
SRV_TDS_NCHAR = $ef;
// Datatypes
// Also: values of symbol parameter to srv_symbol when type = SRV_DATATYPE
SRVNULL = SRV_TDS_NULL;
SRVTEXT = SRV_TDS_TEXT;
SRVGUID = SRV_TDS_GUID;
SRVVARBINARY = SRV_TDS_VARBINARY;
SRVINTN = SRV_TDS_INTN;
SRVVARCHAR = SRV_TDS_VARCHAR;
SRVBINARY = SRV_TDS_BINARY;
SRVIMAGE = SRV_TDS_IMAGE;
SRVCHAR = SRV_TDS_CHAR;
SRVINT1 = SRV_TDS_INT1;
SRVBIT = SRV_TDS_BIT;
SRVINT2 = SRV_TDS_INT2;
SRVDECIMAL = SRV_TDS_DECIMAL;
SRVINT4 = SRV_TDS_INT4;
SRVDATETIM4 = SRV_TDS_DATETIM4;
SRVFLT4 = SRV_TDS_FLT4;
SRVMONEY = SRV_TDS_MONEY;
SRVDATETIME = SRV_TDS_DATETIME;
SRVFLT8 = SRV_TDS_FLT8;
SRVNUMERIC = SRV_TDS_NUMERIC;
SRVNTEXT = SRV_TDS_NTEXT;
SRVBITN = SRV_TDS_BITN;
SRVDECIMALN = SRV_TDS_DECIMALN;
SRVNUMERICN = SRV_TDS_NUMERICN;
SRVFLTN = SRV_TDS_FLTN;
SRVMONEYN = SRV_TDS_MONEYN;
SRVDATETIMN = SRV_TDS_DATETIMN;
SRVMONEY4 = SRV_TDS_MONEY4;
SRVINT8 = SRV_TDS_INT8; // SQL 2000 and later
SRVBIGVARBINARY = SRV_TDS_BIGVARBINARY;
SRVBIGVARCHAR = SRV_TDS_BIGVARCHAR;
SRVBIGBINARY = SRV_TDS_BIGBINARY;
SRVBIGCHAR = SRV_TDS_BIGCHAR;
SRVNVARCHAR = SRV_TDS_NVARCHAR;
SRVNCHAR = SRV_TDS_NCHAR;
// values for srv_symbol type parameter
SRV_ERROR = 0;
SRV_DONE = 1;
SRV_DATATYPE = 2;
SRV_EVENT = 4;
// values for srv_symbol symbol parameter, when type = SRV_ERROR
SRV_ENO_OS_ERR = 0;
SRV_INFO = 1;
SRV_FATAL_PROCESS = 10;
SRV_FATAL_SERVER = 19;
// Types of server events
// Also: values for srv_symbol symbol parameter, when type = SRV_EVENT
SRV_CONTINUE = 0;
SRV_LANGUAGE = 1;
SRV_CONNECT = 2;
SRV_RPC = 3;
SRV_RESTART = 4;
SRV_DISCONNECT = 5;
SRV_ATTENTION = 6;
SRV_SLEEP = 7;
SRV_START = 8;
SRV_STOP = 9;
SRV_EXIT = 10;
SRV_CANCEL = 11;
SRV_SETUP = 12;
SRV_CLOSE = 13;
SRV_PRACK = 14;
SRV_PRERROR = 15;
SRV_ATTENTION_ACK = 16;
SRV_CONNECT_V7 = 16; // TDS type for TDS 7 clients. Overloaded with SRV_ATTENTION_ACK
SRV_SKIP = 17;
SRV_TRANSMGR = 18;
SRV_OLEDB = 20;
SRV_INTERNAL_HANDLER = 99;
SRV_PROGRAMMER_DEFINED = 100;
// values for srv_config option parameter
SRV_CONNECTIONS = 1;
SRV_LOGFILE = 2;
SRV_STACKSIZE = 3;
SRV_REMOTE_ACCESS = 7;
SRV_REMOTE_CONNECTIONS = 9;
SRV_MAX_PACKETS = 10;
SRV_MAXWORKINGTHREADS = 11;
SRV_MINWORKINGTHREADS = 12;
SRV_THREADTIMEOUT = 13;
SRV_MAX_PACKETSIZE = 17;
SRV_THREADPRIORITY = 18;
SRV_ANSI_CODEPAGE = 19;
SRV_DEFAULT_PACKETSIZE = 26;
SRV_PASSTHROUGH = 27;
// vlaues for srv_config value parameter when option = SRV_THREADPRIORITY
SRV_PRIORITY_LOW = THREAD_PRIORITY_LOWEST;
SRV_PRIORITY_NORMAL = THREAD_PRIORITY_NORMAL;
SRV_PRIORITY_HIGH = THREAD_PRIORITY_HIGHEST;
SRV_PRIORITY_CRITICAL = THREAD_PRIORITY_TIME_CRITICAL;
// values for srv_sfield field parameter
SRV_SERVERNAME = 0;
SRV_VERSION = 6;
// Length to indicate string is null terminated
SRV_NULLTERM = -1;
// values of msgtype parameter to srv_sendmsg
SRV_MSG_INFO = 1;
SRV_MSG_ERROR = 2;
// values of status parameter to srv_senddone
// Also: values for symbol parameters to srv_symbol when type = SRV_DONE
SRV_DONE_FINAL = $0000;
SRV_DONE_MORE = $0001;
SRV_DONE_ERROR = $0002;
SRV_DONE_COUNT = $0010;
SRV_DONE_RPC_IN_BATCH = $0080;
// return values of srv_paramstatus
SRV_PARAMRETURN = $0001;
SRV_PARAMDEFAULT = $0002;
// return values of srv_rpcoptions
SRV_RECOMPILE = $0001;
SRV_NOMETADATA = $0002;
// values of field parameter to srv_pfield
// SRV_LANGUAGE 1 already defined above
// SRV_EVENT 4 already defined above
SRV_SPID = 10;
SRV_NETSPID = 11;
SRV_TYPE = 12;
SRV_STATUS = 13;
SRV_RMTSERVER = 14;
SRV_HOST = 15;
SRV_USER = 16;
SRV_PWD = 17;
SRV_CPID = 18;
SRV_APPLNAME = 19;
SRV_TDS = 20;
SRV_CLIB = 21;
SRV_LIBVERS = 22;
SRV_ROWSENT = 23;
SRV_BCPFLAG = 24;
SRV_NATLANG = 25;
SRV_PIPEHANDLE = 26;
SRV_NETWORK_MODULE = 27;
SRV_NETWORK_VERSION = 28;
SRV_NETWORK_CONNECTION = 29;
SRV_LSECURE = 30;
SRV_SAXP = 31;
SRV_UNICODE_USER = 33;
SRV_UNICODE_PWD = 35;
SRV_SPROC_CODEPAGE = 36;
// return value of SRV_TDSVERSION macro
SRV_TDS_NONE = 0;
SRV_TDS_2_0 = 1;
SRV_TDS_3_4 = 2;
SRV_TDS_4_2 = 3;
SRV_TDS_6_0 = 4;
SRV_TDS_7_0 = 5;
// Return values from APIs
type
SRVRETCODE = Integer; // SUCCEED or FAIL
RETCODE = Integer;
const
SUCCEED = 1; // Successful return value
FAIL = 0; // Unsuccessful return value
SRV_DUPLICATE_HANDLER = 2; // additional return value for srv_pre/post_handle
//------------------------------------------------
//PreDeclare structures
//
{struct srv_server;
typedef struct srv_server SRV_SERVER;
struct srv_config;
typedef struct srv_config SRV_CONFIG;
struct srv_proc;
typedef struct srv_proc SRV_PROC;}
type
SRV_SERVER = Pointer;
SRV_CONFIG = Pointer;
SRV_PROC = Pointer;
//------------------------------------------------
//------------------------------------------------
// ODS MACROs & APIs
// Describing and sending a result set
function srv_describe(srvproc: SRV_PROC;
colnumber: Integer; column_name: PCHAR; namelen: Integer;
desttype, destlen, srctype, srclen: Integer; srcData: Pointer
): Integer; cdecl;
function srv_setutype(srvproc: SRV_PROC; column: Integer; usertype: Longint): Integer; cdecl;
function srv_setcoldata(srvproc: SRV_PROC; column: Integer; data: Pointer): Integer; cdecl;
function srv_setcollen(srvproc: SRV_PROC; column, len: Integer): Integer; cdecl;
function srv_sendrow(srvproc: SRV_PROC): Integer; cdecl;
function srv_senddone(srvproc: SRV_PROC; status, curcmd: Word; count: Longint): Integer; cdecl;
// Dealing with Extended Procedure parameters
function srv_rpcparams(srvproc: SRV_PROC): Integer; cdecl;
function srv_paraminfo(srvproc: SRV_PROC; n: Integer; pbType: PByte;
pcbMaxLen, pcbActualLen: PULONG; pbData: PByte; pfNull: PBOOL): Integer; cdecl;
function srv_paramsetoutput(srvproc: SRV_PROC;
n: Integer; pbData: PByte; cbLen: ULONG; fNull: BOOL): Integer; cdecl;
function srv_paramdata(srvproc: SRV_PROC; n: Integer): Pointer; cdecl;
function srv_paramlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_parammaxlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramtype(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramset(srvproc: SRV_PROC; n: Integer; data: Pointer; int: Integer): Integer; cdecl;
function srv_paramname(srvproc: SRV_PROC; n: Integer; var len: Integer): PChar; cdecl;
function srv_paramnumber(srvproc: SRV_PROC; name: PChar; namelen: Integer): Integer; cdecl;
//--------------------------------------------------------------
//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0
// MACROs
{ SRV_GETCONFIG(a) srv_getconfig ( a )
SRV_GETSERVER(a) srv_getserver ( a )
SRV_GOT_ATTENTION(a) srv_got_attention ( a )
SRV_EVENTDATA(a) srv_eventdata ( a )
SRV_IODEAD(a) srv_iodead ( a )
SRV_TDSVERSION(a) srv_tdsversion ( a )}
function srv_getconfig(server: SRV_SERVER): SRV_CONFIG; cdecl;
function srv_getserver(srvproc: SRV_PROC): SRV_SERVER; cdecl;
function srv_got_attention(srvproc: SRV_PROC): Bool; cdecl;
function srv_eventdata(srvproc: SRV_PROC): Pointer; cdecl;
// Memory
function srv_alloc(ulSize: Longint): Pointer; cdecl;
function srv_bmove(from: Pointer; pto: Pointer; count: Longint): Integer; cdecl;
function srv_bzero(location: Pointer; count: Longint): Integer; cdecl;
function srv_free(ptr: Pointer): Integer; cdecl;
function srv_config_fn(config: SRV_CONFIG; option: Longint; value: PChar; valuelen: Integer): Integer; cdecl;
function srv_config_alloc: SRV_CONFIG; cdecl;
function srv_convert(srvproc: SRV_PROC; srctype: Integer; src: Pointer; srclen: DBINT;
desttype: Integer; dest: Pointer; destlen: DBINT): Integer; cdecl;
{
int (* srv_errhandle(int (* handler)(SRV_SERVER * server,
SRV_PROC * srvproc,
int srverror,
BYTE severity,
BYTE state,
int oserrnum,
char * errtext,
int errtextlen,
char * oserrtext,
int oserrtextlen)))
( SRV_SERVER * server,
SRV_PROC * srvproc,
int srverror,
BYTE severity,
BYTE state,
int oserrnum,
char * errtext,
int errtextlen,
char * oserrtext,
int oserrtextlen );
}
function srv_event_fn(srvproc: SRV_PROC; event: Integer; data: PByte): Integer; cdecl;
function srv_getuserdata(srvproc: SRV_PROC): Pointer; cdecl;
function srv_getbindtoken(srvproc: SRV_PROC; token_buf: PChar): Integer; cdecl;
function srv_getdtcxact(srvproc: SRV_PROC; ppv: Pointer): Integer; cdecl;
//typedef int (* EventHandler)(void*);
type
EventHandler = Pointer;
function srv_handle(server: SRV_SERVER; int: Longint; handler: EventHandler): EventHandler; cdecl;
function srv_impersonate_client(srvproc: SRV_PROC): Integer; cdecl;
function srv_init(config: SRV_CONFIG; connectname: PChar; namelen: Integer): SRV_SERVER; cdecl;
function srv_iodead(srvproc: SRV_PROC): Bool; cdecl;
function srv_langcpy(srvproc: SRV_PROC; start, nbytes: Longint; buffer: PChar): Longint; cdecl;
function srv_langlen(srvproc: SRV_PROC): Longint; cdecl;
function srv_langptr(srvproc: SRV_PROC): Pointer; cdecl;
function srv_log(server: SRV_SERVER; datestamp: Bool; msg: PChar; msglen: Integer): Integer; cdecl;
function srv_paramstatus(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_pfield(srvproc: SRV_PROC; field: Integer; len: PInteger): PChar; cdecl;
function srv_returnval(srvproc: SRV_PROC; value_name: PDBCHAR; len: Integer; status: Byte;
iType, maxlen, datalen: DBINT; value: PByte): Integer; cdecl;
function srv_revert_to_self(srvproc: SRV_PROC): Integer; cdecl;
function srv_rpcdb(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcname(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcnumber(srvproc: SRV_PROC): Integer; cdecl;
function srv_rpcoptions(srvproc: SRV_PROC): Word; cdecl;
function srv_rpcowner(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_run(server: SRV_SERVER): Integer; cdecl;
function srv_sendmsg(srvproc: SRV_PROC;
msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
rpcname: PChar; rpcnamelen: Integer;
linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;
function srv_ansi_sendmsg(srvproc: SRV_PROC;
msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
rpcname: PChar; rpcnamelen: Integer;
linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;
function srv_sendstatus(srvproc: SRV_PROC; status: Longint): Integer; cdecl;
function srv_setuserdata(srvproc: SRV_PROC; ptr: Pointer): Integer; cdecl;
function srv_sfield(server: SRV_SERVER; field: Integer; len: PInteger): PChar; cdecl;
function srv_symbol(iType, symbol: Integer; len: PInteger): PChar; cdecl;
function srv_tdsversion(srvproc: SRV_PROC): Integer; cdecl;
function srv_writebuf(srvproc: SRV_PROC; ptr: Pointer; count: Word): Integer; cdecl;
function srv_willconvert(srctype, desttype: Integer): Bool; cdecl;
procedure srv_ackattention(srvproc: SRV_PROC); cdecl;
function srv_terminatethread(srvproc: SRV_PROC): Integer; cdecl;
function srv_sendstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_clearstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_setevent(server: SRV_SERVER; event: Integer): Integer; cdecl;
function srv_message_handler(srvproc: SRV_PROC;
errornum: Integer; severity, state: Byte; oserrnum: Integer; errtext: PChar;
errtextlen: Integer; oserrtext: PChar; oserrtextlen: Integer): Integer; cdecl;
function srv_pre_handle(server: SRV_SERVER; srvproc: SRV_PROC;
event: Longint; handler: EventHandler; remove: Bool): Integer; cdecl;
function srv_post_handle(server: SRV_SERVER; srvproc: SRV_PROC;
event: Longint; handler: EventHandler; remove: Bool): Integer; cdecl;
function srv_post_completion_queue(srvproc: SRV_PROC; inbuf: PChar; inbuflen: PChar): Integer; cdecl;
function srv_IgnoreAnsiToOem(srvproc: SRV_PROC; bTF: BOOL): Integer; cdecl;
//#ifdef __cplusplus
//}
//#endif
//#pragma pack()
const
SS_MAJOR_VERSION = 7;
SS_MINOR_VERSION = 00;
SS_LEVEL_VERSION = 0000;
SS_MINIMUM_VERSION = '7.00.00.0000';
ODS_VERSION = ((SS_MAJOR_VERSION shl 24) or (SS_MINOR_VERSION shl 16));
//#endif //_ODS_SRV_H_
//////////////////////////////////////////////////////////////////
// Suggested implementation of __GetXpVersion
//
//__declspec(dllexport) ULONG __GetXpVersion()
// {
// return ODS_VERSION;
// }
//////////////////////////////////////////////////////////////////
implementation
const
sLibName = 'Opends60.DLL';
function srv_describe; external sLibName name 'srv_describe';
function srv_setutype; external sLibName name 'srv_setutype';
function srv_setcoldata; external sLibName name 'srv_setcoldata';
function srv_setcollen; external sLibName name 'srv_setcollen';
function srv_sendrow; external sLibName name 'srv_sendrow';
function srv_senddone; external sLibName name 'srv_senddone';
// Dealing with Extended Procedure parameters
function srv_rpcparams; external sLibName name 'srv_rpcparams';
function srv_paraminfo; external sLibName name 'srv_paraminfo';
function srv_paramsetoutput; external sLibName name 'srv_paramsetoutput';
function srv_paramdata; external sLibName name 'srv_paramdata';
function srv_paramlen; external sLibName name 'srv_paramlen';
function srv_parammaxlen; external sLibName name 'srv_parammaxlen';
function srv_paramtype; external sLibName name 'srv_paramtype';
function srv_paramset; external sLibName name 'srv_paramset';
function srv_paramname; external sLibName name 'srv_paramname';
function srv_paramnumber; external sLibName name 'srv_paramnumber';
//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0
function srv_getconfig; external sLibName name 'srv_getconfig';
function srv_getserver; external sLibName name 'srv_getserver';
function srv_got_attention; external sLibName name 'srv_got_attention';
function srv_eventdata; external sLibName name 'srv_eventdata';
// Memory
function srv_alloc; external sLibName name 'srv_alloc';
function srv_bmove; external sLibName name 'srv_bmove';
function srv_bzero; external sLibName name 'srv_bzero';
function srv_free; external sLibName name 'srv_free';
function srv_config_fn; external sLibName name 'srv_config';
function srv_config_alloc; external sLibName name 'srv_config_alloc';
function srv_convert; external sLibName name 'srv_convert';
function srv_event_fn; external sLibName name 'srv_event';
function srv_getuserdata; external sLibName name 'srv_getuserdata';
function srv_getbindtoken; external sLibName name 'srv_getbindtoken';
function srv_getdtcxact; external sLibName name 'srv_getdtcxact';
function srv_handle; external sLibName name 'srv_handle';
function srv_impersonate_client; external sLibName name 'srv_impersonate_client';
function srv_init; external sLibName name 'srv_init';
function srv_iodead; external sLibName name 'srv_iodead';
function srv_langcpy; external sLibName name 'srv_langcpy';
function srv_langlen; external sLibName name 'srv_langlen';
function srv_langptr; external sLibName name 'srv_langptr';
function srv_log; external sLibName name 'srv_log';
function srv_paramstatus; external sLibName name 'srv_paramstatus';
function srv_pfield; external sLibName name 'srv_pfield';
function srv_returnval; external sLibName name 'srv_returnval';
function srv_revert_to_self; external sLibName name 'srv_revert_to_self';
function srv_rpcdb; external sLibName name 'srv_rpcdb';
function srv_rpcname; external sLibName name 'srv_rpcname';
function srv_rpcnumber; external sLibName name 'srv_rpcnumber';
function srv_rpcoptions; external sLibName name 'srv_rpcoptions';
function srv_rpcowner; external sLibName name 'srv_rpcowner';
function srv_run; external sLibName name 'srv_run';
function srv_sendmsg; external sLibName name 'srv_sendmsg';
function srv_ansi_sendmsg; external sLibName name 'srv_ansi_sendmsg';
function srv_sendstatus; external sLibName name 'srv_sendstatus';
function srv_setuserdata; external sLibName name 'srv_setuserdata';
function srv_sfield; external sLibName name 'srv_sfield';
function srv_symbol; external sLibName name 'srv_symbol';
function srv_tdsversion; external sLibName name 'srv_tdsversion';
function srv_writebuf; external sLibName name 'srv_writebuf';
function srv_willconvert; external sLibName name 'srv_willconvert';
procedure srv_ackattention; external sLibName name 'srv_ackattention';
function srv_terminatethread; external sLibName name 'srv_terminatethread';
function srv_sendstatistics; external sLibName name 'srv_sendstatistics';
function srv_clearstatistics; external sLibName name 'srv_clearstatistics';
function srv_setevent; external sLibName name 'srv_setevent';
function srv_message_handler; external sLibName name 'srv_message_handler';
function srv_pre_handle; external sLibName name 'srv_pre_handle';
function srv_post_handle; external sLibName name 'srv_post_handle';
function srv_post_completion_queue; external sLibName name 'srv_post_completion_queue';
function srv_IgnoreAnsiToOem; external sLibName name 'srv_IgnoreAnsiToOem';
end.
2011. május 6., péntek
Write a TCP Redirector using Indy
Problem/Question/Abstract:
Many people ask how to write servers in Indy, this primer goes through how a TCP server is created, and how to redirect all traffic to another remote server. This is the same as port-mapping in firewalls.
Answer:
TCP Protocol Redirection Primer
Contents
1 Introduction
1.1 Disclaimer
2 Writing the Server
2.1 Writing the servers OnExecute() method
2.2 Writing the client connection
2.3 Forwarding data to/from the server/client
2.4 Testing the application
3 Where to next ?
4 Another way
1 Introduction
This article explains how to create a TCP protocol redirecter with Delphi 5 or Delphi 6, using the Indy TCP components.
The purpose of this is to show how to accept a real client connection to an IdTCPServer, and then how to further connect to another remote server, and forward all data coming/going to/from the client/server.
In the article well use the resulting application to redirect traffic to the borland.com www site, to port 80. The local port will also be 80, so in effect all traffic coming in on port 80 will be forwarded to borland.com.
1.1 Disclaimer
This article is written by Kim Sandell, September 2002. You can reach me via email at "kim.sandell@nsftele.com" if you have comments or corrections to the material.
This material is free. It may be used in any way the reader sees fit, but at the readers own risk.
2 Writing the Server
In order to write the server, we need to have a new application in delphi, the IdTCPServer component dropped onto the form, and two buttons, one Button1 as a Start button and another Button2 as a Stop button.
The first thing we need to define is the port the IdTCPServer component will listen to. This is done by setting the DefaultPort property of the IcTCPServer1 to 80. (80=www port remember!)
We also need to define the basic functions for the buttons, and create an event handler for incoming client connections.
For the Button1, create an OnClick event handler:
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := True;
end;
and for the Button2, create an OnClick event handler:
procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPServer1.Active := False;
end;
Go to the properties of the Events of the IdTCPServer and create an event handler for the OnExecute event.
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
begin
end;
2.1 Writing the servers OnExecute() method
The OnExecute() event is the place where the client connects to. The parameter "AThread" that is passed with it, is the actial thread with all the information about the connection.
In this demo we will use only a few of these, but when you get the hang of all of this, you can start experimenting a bit with the AThread object.
First we need to make sure that everything that happends in the handler is thread-safe. This means we can not update any visual properties, nor can we use any global variables/objects.
We also want to make sure that if anything goes wrong we can handle the situation and cleanup after the client.
We will begin by making a "Try Except End" plus a "Try Finally End" statement wrapped inside each other.
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
begin
try
try
finally
end;
except
end;
end;
Everything that we do in the OnExecute() method must go inside the try except statement, and most of it will go in the try finally statement.
2.2 Writing the client connection
To make a TCP Client connection to another server/machine we need the IdTCPClient component. We have to make a local variable so that we are thread-safe (see above). This component is found in the IdTCPClient pas file, so we need to include that in the Uses clause in the "implementation" section:
{...}
var
Form1: TForm1;
implementation
uses IdTCPClient; // This line includes the correct component
{$R *.dfm}
{...}
The TCPClient variable well use is called CLI. This has to be declared in the OnExecute() method locally. Also we need to create the component, and make sure it is destroyed once the connection is terminated.
We also want to tell it where to connect to once a client connects to the server, so well set the Host and Port properties of it.
In the finallt statement we want to make sure the real client that connected is also disconnected, so well throw in a Disconnect for the AThread.Connection as well.
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
Cli: TIdTCPClient;
begin
try
Cli := nil;
try
{ Create & Connect to Server }
Cli := TIdTCPClient.Create(nil);
Cli.Host := 'www.borland.com';
Cli.Port := 80;
finally
if Assigned(Cli) then
begin
Cli.Disconnect;
Cli.Free;
end;
{ Disconnect real client }
AThread.Connection.Disconnect;
end;
except
end;
end;
Now when a client connects to us, we need to establish a connection to the remote server, so we immediately try to connect to that server using the Cli.Connect; method.
{...}
try
{ Create & Connect to Server }
Cli := TIdTCPClient.Create(nil);
Cli.Host := 'www.borland.com';
Cli.Port := 80;
{ Connect to the remote server }
Cli.Connect;
finally
{...}
If we get an error (exception) here, the code will jump to the finally statement, where the CLI component is freed, and the connection to the Client is disconnected immediately. In effect the only thing the real client sees is that a connection was made but the connection was immediately lost before any data came through.
2.3 Forwarding data to/from the server/client
Now that we have the real client connected, and we also have a connection to the remote server, we want to start forwarding data to/from the client/server.
This will be done for as long as both parties are connected to us, so well need a loop that keeps checking if data is coming or going.
In the loop well check if the real client has any data to send, and also check if the remote server as any data to send to the client.
We also need to check for disconnection on both ends, since the Indy components do not alwyas notify of disconnections.
Last but not least: We need to make sure the loop does not take 100% CPU time, since it is going pretty fast through the loop. To avoid that we will add a Sleep command at the end of the loop.
The complete OnExecute() handler should now look like this:
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
Cli: TIdTCPClient;
Len: Cardinal;
Data: string;
begin
try
Cli := nil;
try
{ Create & Connect to Server }
Cli := TIdTCPClient.Create(nil);
Cli.Host := 'www.borland.com';
Cli.Port := 80;
{ Connect to the remote server }
Cli.Connect;
{ Read/Write loop }
repeat
{ Read data from Client }
{ Uncomment the line below, depending on your
INDY version }
// <9: If AThread.Connection.CurrentReadBufferSize>0 then
// >9: If Lenght(AThread.Connection.CurrentReadBuffer)>0 then
begin
Len := AThread.Connection.CurrentReadBufferSize;
Data := AThread.Connection.ReadString(Len);
{ Write it to the Server }
Cli.Write(Data);
end;
{ Read data from Server }
if Cli.CurrentReadBufferSize > 0 then
begin
Len := Cli.CurrentReadBufferSize;
Data := Cli.ReadString(Len);
{ Write it to the Server }
AThread.Connection.Write(Data);
end;
{ Check for Disconnects }
Cli.CheckForDisconnect(False);
Cli.CheckForGracefulDisconnect(False);
AThread.Connection.CheckForDisconnect(False);
AThread.Connection.CheckForGracefulDisconnect(False);
{ Release system slizes }
SleepEx(1, True);
until (not AThread.Connection.Connected) or (not Cli.Connected);
finally
if Assigned(Cli) then
begin
Cli.Disconnect;
Cli.Free
end;
{ Disconnect real client }
AThread.Connection.Disconnect;
end;
except
end;
end;
2.4 Testing the application
Compile and run the application.
Try connecting with your browser to the "http://localhost" address.
You should see the borland.com website !!!
Note: This does not work if you must have a proxy defined in your browser !!
3 Where to next ?
Now that you have learned the basics of redirecting TCP connections, I think the next logial step would be to expand the application with more features.
A few suggestions for small enhancements:
Max number of connected users at one time
A timeout disconnect if nothing happends (no data transferred).
Recognise protocols, such as HTTP and actually block unwanted url's from beeing accessed. This would almost be a proxy, even thoug a proxy needs to check where the client wants to go first.
Some of the suggestions are propably easy to implement, others harder. The level of expertiese the programmer (you) has really is the only limit here, and if you want to learn something new, then learning by doing is the best way.
4 Another way
Here is another way of accomplishing the same thing:
Drop a TIdMappedPortTCP from the Indy Servers tab.
Set the MappedHost and MappedPort properties to the server you want the traffic to be redirected to;
Set the DefaultPort property to the port you want to listen for new client connections.
Set Active to True.
Compile and run.
Same thing accomplished w/o a single line of code. This component handles all the work for you. However, one can handle some of the events such as connects, disconnects and so on.
2011. május 5., csütörtök
Creating a simple HTTP Server
Problem/Question/Abstract:
This article shows hot to create a simple HTTP server using TIdHTTPServer component from the Indy Library and the TPageProducer component from Borland for simple scripting capabilities.
Answer:
INTRODUCTION
This time I am writing a short article showing you how to implement the INDY TIdHTTPServer component. We will create a simple HTTP Server that responses to incoming request. Additionally, the server uses Borland TPageProducer component to provide very basic scripting capabilities.
You can download the Indy components at nevrona.com/Indy. This article and the samples are using Indy v9.3 BETA.
First we will design the server. Since this is a demo showing how to use the INDY HTTP Server, we will not design a NT Service, rather a simple application allowing us to better control the server.
Before starting the server, you must choose a web root directory. Additionally you can set a default document, the reader can get, if only a web folder name was requested, similar to the index.htm file on a web server.
INCOMING REQUESTS
All incoming requests must start with a forward slash '/'. If a malformed request is sent to the server we will raise an exception and abort the actions associated. (001)
Next all forward slash characters (/) will be converted to backward slash characters (\) and the file name, as it should be on the server, will be created. (002)
RETURNING THE DOCUMENT REQUESTED
If the user has requested a folder (last character will be a backward slash (\)), we will check for the default document file in the requested folder.
All files ending on '.ehtm' will be sent through our "script" parser. Therefore, we have to check the document type.
· For all .ehtm files, we will create a TPageProducer object and send the document through the parser. The following Tags can be interpreted in this simple version <#DATE>, <#TIME>, <#DATETIME>, and <#SERVER>
· All other files are returned as-is.
WRITING THE DATA TO THE CLIENT
First we check if any stream has been assigned to the response object. If so, we will return the stream and finish. Next we will check for any data and send them back if there are any.
If neither case has occurred we will send back a 404 Error response, indicating, that the requested document has not been found on the server.
As client any HTML Browser can serve.
THE SERVER CODE
unit uMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer, StdCtrls,
ExtCtrls, HTTPApp;
type
TfrmServer = class(TForm)
httpServer: TIdHTTPServer;
chkActive: TCheckBox;
Label1: TLabel;
edtRootFolder: TEdit;
btnGetFolder: TButton;
Label2: TLabel;
edtDefaultDoc: TEdit;
lstLog: TListBox;
Bevel1: TBevel;
btnClearLog: TButton;
procedure btnGetFolderClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure chkActiveClick(Sender: TObject);
procedure btnClearLogClick(Sender: TObject);
procedure httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings;
var ReplaceText: string);
private
procedure Log(Data: string);
procedure LogServerState;
public
end;
var
frmServer: TfrmServer;
implementation
uses
ShlObj, FileCtrl;
{$R *.DFM}
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseCallbackProc(Wnd: HWND; uMsg: UINT;
lParam, lpData: LPARAM): Integer stdcall;
var
Buffer: array[0..MAX_PATH - 1] of char;
begin
case uMsg of
BFFM_INITIALIZED:
if lpData <> 0 then
SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), Buffer);
SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, Integer(@Buffer));
end;
end;
Result := 0;
end;
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseForFolder(Title: string; RootCSIDL: integer = 0;
InitialFolder: string = ''): string;
var
BrowseInfo: TBrowseInfo;
Buffer: array[0..MAX_PATH - 1] of char;
ResultPItemIDList: PItemIDList;
begin
with BrowseInfo do
begin
hwndOwner := Application.Handle;
if RootCSIDL = 0 then
pidlRoot := nil
else
SHGetSpecialFolderLocation(hwndOwner, RootCSIDL,
pidlRoot);
pszDisplayName := @Buffer;
lpszTitle := PChar(Title);
ulFlags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT;
lpfn := BrowseCallbackProc;
lParam := Integer(Pointer(InitialFolder));
iImage := 0;
end;
Result := '';
ResultPItemIDList := SHBrowseForFolder(BrowseInfo);
if ResultPItemIDList <> nil then
begin
SHGetPathFromIDList(ResultPItemIDList, Buffer);
Result := Buffer;
GlobalFreePtr(ResultPItemIDList);
end;
with BrowseInfo do
if pidlRoot <> nil then
GlobalFreePtr(pidlRoot);
end;
// clear log file
procedure TfrmServer.btnClearLogClick(Sender: TObject);
begin
lstLog.Clear;
end;
// got http server root folder
procedure TfrmServer.btnGetFolderClick(Sender: TObject);
var
NewFolder: string;
begin
NewFolder := BrowseForFolder('Web Root Folder', 0, edtRootFolder.Text);
if NewFolder <> '' then
if DirectoryExists(NewFolder) then
edtRootFolder.Text := NewFolder;
end;
// de-activate http server
procedure TfrmServer.chkActiveClick(Sender: TObject);
begin
if chkActive.Checked then
begin
// root folder must exists
if AnsiLastChar(edtRootFolder.Text)^ = '\' then
edtRootFolder.Text :=
Copy(edtRootFolder.Text, 1, Pred(Length(edtRootFolder.Text)));
chkActive.Checked := DirectoryExists(edtRootFolder.Text);
if not chkActive.Checked then
ShowMessage('Root Folder does not exist.');
end;
// de-/activate server
httpServer.Active := chkActive.Checked;
// log to list box
LogServerState;
// set interactive state for user fields
edtRootFolder.Enabled := not chkActive.Checked;
edtDefaultDoc.Enabled := not chkActive.Checked;
end;
// prepare !
procedure TfrmServer.FormCreate(Sender: TObject);
begin
edtRootFolder.Text := ExtractFilePath(Application.ExeName) + 'WebSite';
ForceDirectories(edtRootFolder.Text);
end;
// incoming client request for download
procedure TfrmServer.httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
I: Integer;
RequestedDocument, FileName, CheckFileName: string;
EHTMLParser: TPageProducer;
begin
// requested document
RequestedDocument := RequestInfo.Document;
// log request
Log('Client: ' + RequestInfo.RemoteIP + ' request for: ' + RequestedDocument);
// 001
if Copy(RequestedDocument, 1, 1) <> '/' then
// invalid request
raise Exception.Create('invalid request: ' + RequestedDocument);
// 002
// convert all '/' to '\'
FileName := RequestedDocument;
I := Pos('/', FileName);
while I > 0 do
begin
FileName[I] := '\';
I := Pos('/', FileName);
end;
// locate requested file
FileName := edtRootFolder.Text + FileName;
try
// check whether file or folder was requested
if AnsiLastChar(FileName)^ = '\' then
// folder - reroute to default document
CheckFileName := FileName + edtDefaultDoc.Text
else
// file - use it
CheckFileName := FileName;
if FileExists(CheckFileName) then
begin
// file exists
if LowerCase(ExtractFileExt(CheckFileName)) = '.ehtm' then
begin
// Extended HTML - send through internal tag parser
EHTMLParser := TPageProducer.Create(Self);
try
// set source file name
EHTMLParser.HTMLFile := CheckFileName;
// set event handler
EHTMLParser.OnHTMLTag := pgpEHTMLHTMLTag;
// parse !
ResponseInfo.ContentText := EHTMLParser.Content;
finally
EHTMLParser.Free;
end;
end
else
begin
// return file as-is
// log
Log('Returning Document: ' + CheckFileName);
// open file stream
ResponseInfo.ContentStream :=
TFileStream.Create(CheckFileName, fmOpenRead or fmShareCompat);
end;
end;
finally
if Assigned(ResponseInfo.ContentStream) then
begin
// response stream does exist
// set length
ResponseInfo.ContentLength := ResponseInfo.ContentStream.Size;
// write header
ResponseInfo.WriteHeader;
// return content
ResponseInfo.WriteContent;
// free stream
ResponseInfo.ContentStream.Free;
ResponseInfo.ContentStream := nil;
end
else if ResponseInfo.ContentText <> '' then
begin
// set length
ResponseInfo.ContentLength := Length(ResponseInfo.ContentText);
// write header
ResponseInfo.WriteHeader;
// return content
end
else
begin
if not ResponseInfo.HeaderHasBeenWritten then
begin
// set error code
ResponseInfo.ResponseNo := 404;
ResponseInfo.ResponseText := 'Document not found';
// write header
ResponseInfo.WriteHeader;
end;
// return content
ResponseInfo.ContentText := 'The document requested is not availabe.';
ResponseInfo.WriteContent;
end;
end;
end;
procedure TfrmServer.Log(Data: string);
begin
lstLog.Items.Add(DateTimeToStr(Now) + ' - ' + Data);
end;
procedure TfrmServer.LogServerState;
begin
if httpServer.Active then
Log(httpServer.ServerSoftware + ' is active')
else
Log(httpServer.ServerSoftware + ' is not active');
end;
procedure TfrmServer.pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
LTag: string;
begin
LTag := LowerCase(TagString);
if LTag = 'date' then
ReplaceText := DateToStr(Now)
else if LTag = 'time' then
ReplaceText := TimeToStr(Now)
else if LTag = 'datetime' then
ReplaceText := DateTimeToStr(Now)
else if LTag = 'server' then
ReplaceText := httpServer.ServerSoftware;
end;
end.
2011. május 4., szerda
Determining the actual length of a DBCS string (multibyte-character ANSI string)
Problem/Question/Abstract:
How can I get the length in characters of a multibyte-character string? Function Length returns the length in bytes, but in Eastern languages some characters may take more than one byte...
Answer:
Solve 1:
Introduction
The Length function returns the length of a string, but it behaves differently according to the type of the string. For the old short strings (ShortString) and for long strings (AnsiString), Length returns the number of bytes they take, while for wide (Unicode) strings (WideString) it returns the number of wide characters (WideChar), that is, the number of bytes divided by two. In the case of short and long strings, in Western languages one character takes one byte, while for example in Asian languages some characters take one and others two bytes. For this reason, there are two versions of almost all string functions, one of great performance that only works with single-byte character strings (SBCS) and another -less performant- one that also works with strings where a character can take one or two bytes (DBCS) that are used in applications distributed internationally. This way we have functions like Pos, LowerCase and UpperCase on one side and AnsiPos, AnsiLowerCase and AnsiUpperCase on the other. Curiosly there is no AnsiLength function that returns the number of characters in a DBCS.
AnsiLength (Draft)
Then here it goes a function that returns the number of characters in a double-byte character string:
function AnsiLength(const s: string): integer;
var
i, n: integer;
begin
Result := 0;
n := Length(s);
i := 1;
while i <= n do
begin
inc(Result);
if s[i] in LeadBytes then
inc(i);
inc(i);
end;
end;
AnsiLength (Final)
Naturally, this function is not optimized. We are not going to mess with assembler, but at least we can use pointers:
function AnsiLength(const s: string): integer;
var
p, q: pchar;
begin
Result := 0;
p := PChar(s);
q := p + Length(s);
while p < q do
begin
inc(Result);
if p^ in LeadBytes then
inc(p, 2)
else
inc(p);
end;
end;
Solve 2:
function AnsiLength(const s: string): integer;
var
p: PAnsiChar;
begin
Result := MultiByteToWideChar(CP_ACP, 0, PAnsiChar(s), -1, NULL, 0);
end;
The documentation on MultiByteToWideChar says:
"If the function succeeds, and cchWideChar is zero, the return value is the required size, in wide characters, for a buffer that can receive the translated string." Number of wide characters is, actually, the number of characters in MBCS.
Solve 3:
function AnsiLength(const s: string): integer;
begin
Result := lstrlenA(PAnsiChar(s));
Result := MultiByteToWideChar(CP_ACP, 0, PAnsiChar(s), -1, NULL, 0);
end;
The documentation on MultiByteToWideChar says:
"If the function succeeds, and cchWideChar is zero, the return value is the required size, in wide characters, for a buffer that can receive the translated string." The number of wide characters for the buffer is, actually, the number of characters in the string - it's length.
Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php
2011. május 3., kedd
A Quick Way to Shortcuts
Problem/Question/Abstract:
A Component for Creating and Modifying Shortcuts
Answer:
Windows shortcuts provide a way to have as many links to a file as you need - in as many folders as you want. Shortcuts are also the tool for adding a file to the Windows Start menu.
In Windows 3.x, creating shortcuts was easy. You had to learn a couple of simple DDE calls, and that was it. In 32-bit Windows, working with shortcuts is more complex, and requires the use of COM and interfaces. This article will look at working with shortcuts in detail, and show you how to build a custom component you can use to create and modify shortcuts in any folder.
The Interfaces
Shortcuts, or links as they are sometimes called, are actually binary files stored on your hard disk with the .lnk extension. The Windows shell includes a COM object named ShellLink for working with shortcuts. The ShellLink object implements two interfaces, IShellLink and IPersistFile, that define the methods for working with shortcuts. Figure 1 shows the declaration of IShellLink from SHLOBJ.PAS, and Figure 2 shows the declaration of IPersistFile from ACTIVEX.PAS.
IShellLinkA = interface(IUnknown) { sl. }
[SID_IShellLinkA]
function GetPath(pszFile: PAnsiChar; cchMaxPath: Integer;
var pfd: TWin32FindData; fFlags: DWORD): HResult;
stdcall;
function GetIDList(var ppidl: PItemIDList): HResult;
stdcall;
function SetIDList(pidl: PItemIDList): HResult; stdcall;
function GetDescription(pszName: PAnsiChar;
cchMaxName: Integer): HResult; stdcall;
function SetDescription(pszName: PAnsiChar): HResult;
stdcall;
function GetWorkingDirectory(pszDir: PAnsiChar;
cchMaxPath: Integer): HResult; stdcall;
function SetWorkingDirectory(pszDir: PAnsiChar): HResult;
stdcall;
function GetArguments(pszArgs: PAnsiChar;
cchMaxPath: Integer): HResult; stdcall;
function SetArguments(pszArgs: PAnsiChar): HResult;
stdcall;
function GetHotkey(var pwHotkey: Word): HResult; stdcall;
function SetHotkey(wHotkey: Word): HResult; stdcall;
function GetShowCmd(out piShowCmd: Integer): HResult;
stdcall;
function SetShowCmd(iShowCmd: Integer): HResult; stdcall;
function GetIconLocation(pszIconPath: PAnsiChar;
cchIconPath: Integer; out piIcon: Integer): HResult;
stdcall;
function SetIconLocation(pszIconPath: PAnsiChar;
iIcon: Integer): HResult; stdcall;
function SetRelativePath(pszPathRel: PAnsiChar;
dwReserved: DWORD): HResult; stdcall;
function Resolve(Wnd: HWND; fFlags: DWORD): HResult;
stdcall;
function SetPath(pszFile: PAnsiChar): HResult; stdcall;
end;
Figure 1: The IShellLink interface.
IPersistFile = interface(IPersist)
['{ 0000010B-0000-0000-C000-000000000046 }']
function IsDirty: HResult; stdcall;
function Load(pszFileName: POleStr; dwMode: Longint):
HResult; stdcall;
function Save(pszFileName: POleStr; fRemember: BOOL):
HResult; stdcall;
function SaveCompleted(pszFileName: POleStr): HResult;
stdcall;
function GetCurFile(out pszFileName: POleStr): HResult;
stdcall;
end;
Figure 2: The IPersistFile interface.
Into the TWinShortcut Component
The shell of the TWinShortcut custom component was created with the Component Wizard in the Object Repository, using TComponent as its ancestor Listing One shows the finished component. To make things easier to find, the properties and their private member variables are in alphabetical order. In the implementation section, the methods are divided into three groups: constructor and destructor, property getter and setter, and custom methods. Within each of these groups, the methods are in alphabetical order. The constructor is overridden to automatically create an instance of the ShellLink object using the following code:
FShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
FPersistFile := FShellLink as IPersistFile;
The first statement creates the ShellLink object by calling CreateCOMObject and passing the ShellLink object's class ID as the parameter. The return value is cast to type IShellLink to provide a reference to the IShellLink interface and its methods. FShellLink is a protected member variable of type IShellLink. FPersistFile is also a protected member variable and is of type IPersistFile. Casting FShellLink to IPersistFile provides an interface reference to the IPersistFile methods implemented by the ShellLink object. TWinShortcut's destructor is overridden, and both FShellLink and FPersistFile are set to nil to destroy the ShellLink object. Because COM objects are reference counted, both variables must be set to nil before the ShellLink object will be destroyed.
You must be able to specify the name and location of the shortcut file you want to work with, and that capability is provided by three properties: ShortcutFileName, ShortcutPath, and SpecialFolderLocation. One big problem in working with shortcuts is figuring out where to create them. For example, if you want to create a shortcut on the user's desktop, you have to know the path to the desktop folder, and that is different for different versions of Windows.
The solution is a Windows API function named SHGetSpecialFolderLocation, which takes three parameters. The first is a window handle, which can be set to zero. The second is a constant that identifies the folder you want. To find a partial list of constants, click Start | Programs | Borland Delphi 5 | Help | MS SDK Help Files | Win32 Programmers Reference and search for SHGetSpecialFolderLocation. If you have the MSDN Library CD, search for SHGetSpecialFolderLocation and you'll find a list of over 40 folder constants. The Win32 Programmers Reference Help file also contains detailed information about IShellLink and IPersistFile and their methods. The third parameter is a variable of type PItemIdList.
After calling SHGetSpecialFolderLocation, you will call SHGetPathFromIdList to extract the actual path from the PItemIdList parameter. The SpecialFolderLocation property of TWinShortcut is of type Word and corresponds to the second parameter, the folder number, of SHGetSpecialFolderLocation. This lets you specify the location of the shortcut by setting the value of the SpecialFolderLocation property, or by providing a path in the ShortcutPath property.
TWinShortcut has a public OpenShortcut method that's used to open an existing shortcut. This method is only three statements long. The first statement is a call to the protected method GetFullShortcutPath. GetFullShortcutPath returns the full path and filename of the shortcut. The second statement, shown here, actually opens the file by calling the IPersistFile interface's Load method:
OleCheck(FPersistFile.Load(PWideChar(WideString(FullPath)),
STGM_READWRITE));
Load's two parameters are the name of the file and the mode. Because this function is Unicode-compatible, the path must be a null-terminated string of wide chars. Because the call to GetFullShortcutPath returns a Pascal ANSI string, the path variable FullPath is first cast to type WideString, and then cast to type PWideChar to match the type of the parameter. Note that Load is called as a parameter to the OleCheck procedure. OleCheck examines the value returned by SHGetSpecialFolderLocation, and if that value indicates an error, OleCheck raises an EOleSysError exception. This technique is used for all of the interface method calls in this example, so normal Delphi exception handling can be used to trap errors that occur when using this component. The last line of the LoadShortcut method calls the custom method GetPropertiesFromShortcut, which calls each of the get methods of the IShellLink interface and assigns the returned value to the corresponding property of TWinShortcut.
Before continuing, let's look at the GetFullShortcutPath and GetPropertiesFromShortcut methods used by OpenShortcut. If the ShortcutPath property is null, GetFullShortcutPath calls GetSpecialFolderPath. Otherwise, it assigns the value of the ShortcutPath property to Result. It then adds the ShortcutFileName property to the end of the string. This is safe because GetSpecialFolderPath always returns a path that ends with a backslash, and the write method for the ShortcutPath property ensures that the property value always ends with a backslash. The write method for the ShortcutFileName property ensures that the filename always includes the .lnk extension.
GetSpecialFolderPath calls SHGetSpecialFolderLocation and passes the value of the SpecialFolderLocation property as the second parameter. This call loads the ItemIdList variable passed as the third parameter. Next, GetSpecialFolderPath calls SHGetPathFromIdList, passing two parameters. The first is the ItemIdList variable initialized by the call to SHGetSpecialFolderLocation, and the second is a char array, CharStr, into which the path will be placed. Finally, CharStr is assigned to the Result variable and a backslash is appended to the path.
The final step in the OpenShortcut method is the call to GetPropertiesFromShortcut. This method calls each of the get methods in the IShellLink interface and assigns the returned value to the corresponding property of TWinShortcut. For example, the first call is to the IShellLink GetPath method, which returns the path to the target file, i.e. the file to which the shortcut points. These calls are straightforward with two exceptions. If you create a shortcut manually in Windows, and the shortcut is to a program that requires command-line arguments, you type them in the Target edit box following the path to the EXE file. However, the command-line arguments are stored separately in the shortcut file and are retrieved with a separate call, GetArguments.
The call to GetHotkey returns the hotkey information in a single parameter of type Word. The virtual key code is stored in the low byte, and the modifier flags that indicate which shift keys were pressed are stored in the high-order byte. If you want to display the hotkey as text, or give users the ability to enter a hotkey, the easy way is to use the THotkey component from the Win32 page of the Component palette. The problem is that the THotkey component stores the virtual key code in its HotKey property, and the modifier flags in its Modifiers property. To make things worse, the values used to represent the [Ctrl], [Alt], [Shift], and extended keys in the high byte of the value returned by GetHotkey, aren't the same as the values used to represent the same keys in the Modifiers property of THotkey.
(Note: The extended-key flag indicates whether the keystroke message originated from one of the additional keys on the enhanced keyboard. The extended keys consist of the [Alt] and [Ctrl] keys on the right-hand side of the keyboard; the [Ins], [Del], [Home], [End], [PageUp], [PageDown], and the arrow keys to the left of the numeric keypad; the [NumLock] key; the k key; the [PrintScreen] key; and the divide (/) and [Enter] keys in the numeric keypad. The extended-key flag is set if the key is an extended key.)
To make life easier for anyone using TWinShortcut, it has two properties, Hotkey and HotkeyModifiers, that are assignment-compatible with the properties of THotkey. The code following the call to GetHotkey converts the modifier flags from the form used by GetHotkey to the form used by the HotkeyModifiers property and by the THotkey component. The modifier constants used with GetHotkey and SetHotkey (HOTKEYF_ALT, HOTKEYF_CONTROL, HOTKEYF_SHIFT and HOTKEYF_EXT) are declared in the CommCtrl.pas unit. The constants used with the THotkey component's Modifiers property (hkAlt, hkCtrl, hkShift, and hkExt) are declared in the ComCtrls.pas unit.
Creating or saving a modified shortcut is handled by the TWinShortcut's public SaveShortcut method. SaveShortcut begins by calling PutPropertiesToShortcut. This method calls the IShellLink put method for each property to assign the current value of the TWinShortcut properties to the corresponding shortcut properties. The only part of this process that is complex is converting the HotkeyModifiers property to the form required by the SetHotkey method. The series of if statements set the appropriate bits in the byte variable HotKeyMods. SetHotkey is called with a single-word parameter that's constructed by shifting HotKeyMods left eight bits to place it in the high-order byte of the word and adding the value of the HotKey property. Next, a call to GetFullShortcutPath returns the path to the link file. Finally, the IPersistFile Save method is called with the full path to the link file as a parameter. Again, the path must be cast first to a WideString, and then to a PWideChar.
Conclusion
You can create and modify any Windows shortcut using the methods of the IShellLink and IPersistFile interfaces implemented by the ShellLink object. Although this article doesn't cover every method in detail, it should give you everything you need for most shortcut operations. For more detailed information about the interfaces or any of their methods, consult the Win32 Programmers Reference online help file that's installed with Delphi 5.
Listing One - TWinShortcut
unit WinShortcut;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, ComObj, ShlObj, ShellAPI, ActiveX, Menus,
ComCtrls;
type
TWinShortcut = class(TComponent)
private
{ Private declarations. }
FArguments: string;
FDescription: string;
FHotkey: Word;
FHotKeyModifiers: THKModifiers;
FIconFile: string;
FIconIndex: Integer;
FShortcutFileName: string;
FShortcutPath: string;
FRunWindow: Integer;
FSpecialFolder: Integer;
FTarget: string;
FWorkingDirectory: string;
protected
{ Protected declarations. }
FPersistFile: IPersistFile;
FShellLink: IShellLink;
function GetFullShortcutPath: string;
procedure GetPropertiesFromShortcut;
function GetSpecialFolderPath: string;
procedure PutPropertiesToShortcut;
procedure SetShortcutFileName(Value: string);
procedure SetShortcutPath(Value: string);
procedure SetSpecialFolder(Value: Integer);
public
{ Public declarations. }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure OpenShortcut;
procedure SaveShortcut;
published
{ Published declarations. }
property Arguments: string
read FArguments write FArguments;
property Description: string
read FDescription write FDescription;
property HotKey: Word read FHotkey write FHotkey;
property HotKeyModifiers: THKModifiers
read FHotKeyModifiers write FHotKeyModifiers;
property IconFile: string
read FIconFile write FIconFile;
property IconIndex: Integer
read FIconIndex write FIconIndex;
property RunWindow: Integer
read FRunWindow write FRunWindow;
property Target: string read FTarget write FTarget;
property ShortcutFileName: string
read FShortcutFileName write SetShortcutFileName;
property ShortcutPath: string
read FShortcutPath write SetShortcutPath;
property SpecialFolder: Integer
read FSpecialFolder write SetSpecialFolder;
property WorkingDirectory: string
read FWorkingDirectory write FWorkingDirectory;
end;
procedure Register;
implementation
uses CommCtrl;
const
Backslash = '\';
LinkExtension = '.LNK';
{ ********* Constructor and Destructor ********** }
constructor TWinShortcut.Create(AOwner: TComponent);
begin
{ Create the ShellLink object and get an IShellLink and
an IPersistFile reference to it. }
inherited;
FShellLink :=
CreateComObject(CLSID_ShellLink) as IShellLink;
FPersistFile := FShellLink as IPersistFile;
end;
destructor TWinShortcut.Destroy;
begin
{ Free the ShellLink object. }
FShellLink := nil;
FPersistFile := nil;
inherited;
end;
{ ********* Property Getter and Setter Methods ********** }
procedure TWinShortcut.SetShortcutFileName(Value: string);
begin
FShortcutFileName := Value;
{ If the file name does not end with the .LNK extension,
add the extension. }
if CompareText(ExtractFileExt(FShortcutFileName),
LinkExtension) <> 0 then
FShortcutFileName := FShortcutFileName + LinkExtension;
end;
procedure TWinShortcut.SetShortcutPath(Value: string);
begin
FShortcutPath := Value;
{ Make sure the path ends with a backslash. }
if Copy(FShortcutPath,
Length(FShortcutPath), 1) <> Backslash then
FShortcutPath := FShortcutPath + Backslash;
end;
procedure TWinShortcut.SetSpecialFolder(Value: Integer);
begin
FSpecialFolder := Value;
{ Clear the ShortcutPath when a value is assinged to the
SpecialFolder property. The SpecialFolder property will
not be used to get the path to the link file if the
ShortcutPath property is not null. }
FShortcutPath := '';
end;
{ ********* Custom Methods ********** }
function TWinShortcut.GetFullShortcutPath: string;
{ Gets the path to the shortcut file. If the ShortcutPath
property is null, the path comes from the SpecialFolder
property. }
begin
if FShortcutPath = '' then
Result := GetSpecialFolderPath
else
Result := FShortcutPath;
Result := Result + FShortcutFileName;
end;
procedure TWinShortcut.GetPropertiesFromShortcut;
{ Calls the appropriate IShellLink method to get the value
of each property of the link and assign that value to the
corresponding property of this component. }
var
CharStr: array[0..MAX_PATH] of Char;
WinFindData: TWin32FindData;
RunWin: Integer;
HotKeyWord: Word;
HotKeyMod: Byte;
begin
OleCheck(FShellLink.GetPath(CharStr, MAX_PATH,
WinFindData, SLGP_UNCPRIORITY));
Target := CharStr;
OleCheck(FShellLink.GetArguments(CharStr, MAX_PATH));
Arguments := CharStr;
OleCheck(FShellLink.GetDescription(CharStr, MAX_PATH));
Description := CharStr;
OleCheck(
FShellLink.GetWorkingDirectory(CharStr, MAX_PATH));
WorkingDirectory := CharStr;
OleCheck(FShellLink.GetIconLocation(CharStr, MAX_PATH,
FIconIndex));
IconFile := CharStr;
OleCheck(FShellLink.GetShowCmd(RunWin));
RunWindow := RunWin;
OleCheck(FShellLink.GetHotkey(HotKeyWord));
{ Extract the HotKey and Modifier properties. }
HotKey := HotKeyWord;
HotKeyMod := Hi(HotKeyWord);
if (HotKeyMod and HOTKEYF_ALT) = HOTKEYF_ALT then
Include(FHotKeyModifiers, hkAlt);
if (HotKeyMod and HOTKEYF_CONTROL) = HOTKEYF_CONTROL then
Include(FHotKeyModifiers, hkCtrl);
if (HotKeyMod and HOTKEYF_SHIFT) = HOTKEYF_SHIFT then
Include(FHotKeyModifiers, hkShift);
if (HotKeyMod and HOTKEYF_EXT) = HOTKEYF_EXT then
Include(FHotKeyModifiers, hkExt);
end;
function TWinShortcut.GetSpecialFolderPath: string;
{ Returns the full path to the special folder specified in
the SpecialFolder property. A backslash is appended to
the path. }
var
ItemIdList: PItemIdList;
CharStr: array[0..MAX_PATH] of Char;
begin
OleCheck(ShGetSpecialFolderLocation(0, FSpecialFolder,
ItemIdList));
if ShGetPathFromIdList(ItemIdList, CharStr) then
begin
Result := CharStr;
Result := Result + Backslash;
end; // if
end;
procedure TWinShortcut.OpenShortcut;
{ Opens the shortcut and loads its properties into the
component properties. }
var
FullPath: string;
begin
FullPath := GetFullShortcutPath;
OleCheck(FPersistFile.Load(PWideChar(WideString(
FullPath)), STGM_READWRITE));
GetPropertiesFromShortcut;
end;
procedure TWinShortcut.PutPropertiesToShortcut;
{ Calls the appropriate IShellLink method to assign the
value of each of the components properties to the
corresponding property of the shortcut. }
var
HotKeyMods: Byte;
begin
HotKeyMods := 0;
OleCheck(FShellLink.SetPath(PChar(FTarget)));
OleCheck(FShellLink.SetIconLocation(PChar(FIconFile),
FIconIndex));
OleCheck(FShellLink.SetDescription(PChar(FDescription)));
OleCheck(FShellLink.SetWorkingDirectory(PChar(
FWorkingDirectory)));
OleCheck(FShellLink.SetArguments(PChar(FArguments)));
OleCheck(FShellLink.SetShowCmd(FRunWindow));
if hkShift in FHotKeyModifiers then
HotKeyMods := HotKeyMods or HOTKEYF_SHIFT;
if hkAlt in FHotKeyModifiers then
HotKeyMods := HotKeyMods or HOTKEYF_ALT;
if hkCtrl in FHotKeyModifiers then
HotKeyMods := HotKeyMods or HOTKEYF_CONTROL;
if hkExt in FHotKeyModifiers then
HotKeyMods := HotKeyMods or HOTKEYF_EXT;
OleCheck(
FShellLink.SetHotkey((HotKeyMods shl 8) + HotKey));
end;
procedure TWinShortcut.SaveShortcut;
{ Copies the component properties to the shortcut
and saves it. }
var
FullPath: string;
begin
PutPropertiesToShortcut;
FullPath := GetFullShortcutPath;
OleCheck(FPersistFile.Save(PWideChar(
WideString(FullPath)), True));
end;
procedure Register;
begin
RegisterComponents('DI', [TWinShortcut]);
end;
end.
End Listing One
Component Download: http://www.baltsoft.com/files/dkb/attachment/A_Quick_Way_to_Shortcuts.zip
2011. május 2., hétfő
Implementing Plug-Ins for Your Delphi Applications
Problem/Question/Abstract:
How to Implementing Plug-Ins for Your Delphi Applications
Answer:
Back in January, 1999, Delphi Informant ran an article on developing plugins for your Delphi applications. It covered some of the basics of that plugins are, how to make them, exporting fucntions, and so on. I was tremendously inspired, because a system I was (and still am) working on could (and did!) benefit greatly from such a technology.
However, the layout that was described had some pretty big flaws. First, it wasn't really OOP. Second, it was a little hairy to pass information back and forth. Finally, you had to write a lot of the initialization stuff yourself. There had to be a better way.
A quick overview of what a plugin is: Plugins are DLL files. They contain additional commands or other functionality that can add to your system. Often they add menu items or toolbuttons to your application. Simply the existance of a file can radically enhance your software.
There was. Step 1 was to create an abstract, base class for a plugin. The plugin should know a bit about the application (for example, having a copy of the Application variable could be useful). It should know a bit about itself: how many "commands" it has, what the name of the plugin was, the author, etc. After some fuddling, this is what I came up with:
type
�� TuilPlugin = class(TObject)
�� private
����FHostApplication: TApplication;
����� FFilename�������: string;
����� FManager��������: TComponent;
�� protected
����� { Protected declarations }
�� public
����� { Public declarations }
����� constructor Create;
����� destructor Destroy; override;
����� function GetAuthor: string; virtual; stdcall;
����� function GetDescription: string; virtual; stdcall;
����� function GetName: string; virtual; stdcall;
����� function Initialize(Manager: TComponent; HostApplication: TApplication;
Filename: string): Boolean; virtual; stdcall;
����� function GetNumCommands: Integer; virtual; stdcall;
����� procedure GetCommand(index: integer; var Caption, Hint, Data: string; var
Bitmap: HBitmap; var Event: TNotifyEvent); virtual; stdcall;
����� procedure Configure; virtual; stdcall;
����� { properties }
����� property HostApplication: TApplication read FHostApplication;
����� property Filename: string read FFilename;
����� property Manager: TComponent read FManager;
��
end;
� { TuilPlugin }
Most of the methods and properties are self explanatory. Each plugin publishes a number of commands (how many is returned by GetNumCommands). To get information about a specific command, a call to GetCommand will give you the command's caption, bitmap, hint and event. Notice the stdcall after each of the methods. This is required by the dll in order for it to work properly.
The second thing that needed to be done was to develop a loader component, which would take care of all the drudgery of creating, initializing, destroying and generally managing the plugins. Here's what I came up with:
�� TuilPluginManager = class(TComponent)
�� private
����� // Private declarations
����� FExtension������: string;
����� FPlugins��������: TList;
����� FOnBeforeLoading: TNotifyEvent;
����� FOnAfterLoading�: TNotifyEvent;
����� FOnBeforeLoad���: TuilBeforeLoadEvent;
����� FOnAfterLoad����: TuilAfterLoadEvent;
����� FOnNewCommand���: TNewCommandEvent;
�� protected
��[...]
�� public
����� // Public declarations
����� constructor Create(AOwner: TComponent); override;
����� destructor Destroy; override;
����� procedure LoadPlugin(Filename: string); virtual;
����� procedure LoadPlugins; virtual;
����� procedure UnloadPlugin(index: integer); virtual;
����� procedure GetLoadedPlugins(PluginList: TStrings); virtual;
����� property Plugins[index: integer]: TuilPlugin read GetPlugins; default;
� // Public
����� property PluginCount: integer read GetPluginCount;
�� published
����� // Published properties and events
����� property Extension: string read GetExtension write SetExtension;
� // Published
����� property Version: string read GetVersion write SetVersion;
����� property OnBeforeLoading: TNotifyEvent read FOnBeforeLoading write
FOnBeforeLoading;
����� property OnAfterLoading: TNotifyEvent read FOnAfterLoading write
FOnAfterLoading;
����� property OnBeforeLoad: TuilBeforeLoadEvent read FOnBeforeLoad write
FOnBeforeLoad;
����� property OnAfterLoad: TuilAfterLoadEvent read FOnAfterLoad write FOnAfterLoad;
����� property OnNewCommand: TNewCommandEvent read FOnNewCommand write
FOnNewCommand;
��
end;
� // TuilPluginManager
The main meat procedure here is LoadPlugin. It handles the actual loading and initialization of a plugin. LoadPlugins is useful as well, since it globally loads all the plugins in the application's folder.
All this is well and good, but how the heck do we make our OWN plugins? Actually, it's really simple.
First, you want to create a descendant of the TuilPlugin class. Include (private) event handlers for each of the commands you want to export.
type
�� TMyPlugin = class(TuilMyPlugin)
����� procedure Command1(Sender: TObject);
����� procedure Command2(Sender: TObject);
�� public
����� function GetAuthor: string; override; stdcall;
����� function GetDescription: string; override; stdcall;
����� function GetName: string; override; stdcall;
����� function Initialize(Manager: TComponent; HostApplication: TApplication;
Filename: string): Boolean; override; stdcall;
����� function GetNumCommands: Integer; override; stdcall;
����� procedure GetCommand(index: integer; var Caption, Hint, Data: string; var
Bitmap: HBitmap; var Event: TNotifyEvent); override; stdcall;
����� procedure Configure; override; stdcall;
��
end;
The two most important methods you override are GetNumCommands and GetCommand. GetNumCommands is easy. In this case, we've got 2 commands we're exporting:
function TMyPlugin.GetNumCommands: integer;
begin
�� Result := 2;
end;
GetCommand is a little trickier. You need to determine what command number you're getting, and return the appropriate information and event handler:
procedure TupSamplePlugin.GetCommand(index: integer; var Caption, Hint, Data: string;
var Bitmap: HBitmap; var Event: TNotifyEvent);
begin
� Caption := '';
� Event := nil;
� case index of
��� 0:
begin
���������� Caption := 'Command One';
���������� Hint := 'Command One';
���������� Data := '';
���������� Event := CommandOne;
������������������ Bitmap := 0;
��������
end;
��� 1:
begin
���������� Caption := 'Command Two';
���������� Hint := 'Command Two';
���������� Data := '';
���������� Event := CommandTwo;
������������������ Bitmap := 0;
��������
end;
�
end;
end;
That's most of it, believe it or not. We have to export a RegisterPlugin procedure with our dll, and include ShareMem as the first unit in both the DLL and our application's .DPR files.
Because there is so much to make sure you do (Sharemem, stdcall, RegisterPlugin, and so on), I put together a Wizard that would make things a lot easier.
I've included the complete source code for the system, including the wizard, available for free. If you are using Delphi 3, there is different code which you can get by clicking here. Feel free to play with it and let me know what you think. I'm hoping that we can continue to improve the system as a community. Comments are welcome!
2011. május 1., vasárnap
InterBase 6
Problem/Question/Abstract:
More Than Open Source
Answer:
The feature of InterBase 6 that has received the most attention is its change to being an open source product. However, InterBase 6 also provides a host of important new features for database developers. This article provides a brief description of many of the new features of InterBase 6, including: large exact numerics, new administrative tools, replication, a more powerful ALTER TABLE command, and much more.
Large Exact Numerics
Perhaps the most important new feature for business application developers is called large exact numerics. In prior versions, InterBase implemented the Numeric and Decimal data types in an unusual way. Numeric and Decimal are fixed-decimal data types. When you declare them, you must specify two numbers called precision and scale. Precision is the total number of digits the column can contain; scale is the number of digits to the right of the decimal point. Precision is limited to 18 digits. For example, a column declared as NUMERIC(15,2) would hold a total of 15 digits, and two of those 15 digits would be to the right of the decimal point. The difference between the Numeric type and the Decimal type is that the Numeric type always stores precision digits and the Decimal type stores precision digits or more.
The SQL standard defines the Numeric and Decimal data types primarily to provide precise storage for money amounts, but they are equally useful for any amount that requires a fractional part to be stored accurately. This contrasts with floating point data types, which store fractional amounts approximately. This imprecision can lead to errors that are unacceptable in financial applications. For example, if you store monetary amounts in floating-point format, it's possible to add a large number of values and have the result be off by a penny. In prior versions of InterBase, Numeric and Decimal columns whose precision was nine or less were stored as integers; however, if the precision was greater than nine they were stored in floating-point format, with the resulting lack of precision in the fractional part.
InterBase 6 stores all Numeric and Decimal values as scaled integers, so the numbers are always stored precisely. Columns with a precision up to four are stored as 16-bit integers. Those with a precision of five through nine are stored as 32-bit integers and columns whose precision is greater than nine are stored as 64-bit integers. Another important use of the Numeric and Decimal data types in InterBase 6 is for primary keys, because generators now return a 64-bit integer value instead of the 32-bit integer returned in prior versions. Since there is no 64-bit integer data type you must use Numeric or Decimal to store integer values beyond the range of a 32-bit integer.
Dialects
InterBase 6 introduces the concept of dialects as a way to implement new features required by the SQL 92 standard that conflict with features in previous versions of InterBase. InterBase 6 implements three dialects. Dialect one is compatible with older versions of InterBase; dialect two is a diagnostic mode; and dialect three introduces support for quoted identifiers, large exact numerics, and the SQL Date, Time, and TimeStamp data types.
In dialect one a string constant in a SQL statement can be delimited by single or double quotes. In dialect three, string constants must be enclosed in single quotes. Double quotes are reserved for the names of database objects which are reserved words, contain spaces, contain non-ASCII characters, or are case-sensitive. Although quoted identifiers can include spaces followed by other characters, they cannot include trailing spaces.
Until now, the Date data type, which contains both date and time information, was the only way to store date and time information in InterBase. Dialect three introduces the SQL 92 Date, Time, and TimeStamp types. Date fields store date information only, Time fields store time information only, and TimeStamp is equivalent to the dialect one Date type and stores both the date and time. If you back up a version 5 or older database and restore it in version 6, all Date columns and domains will be converted to TimeStamp. InterBase 6 also introduces the CURRENT_DATE, CURRENT_TIME, and CURRENT_TIMESTAMP functions to retrieve the current date, time, or date and time, respectively. Also new is the EXTRACT function for extracting information from the data types that contain date and/or time information. For example:
EXTRACT(YEAR FROM SomeDate)
would return the year portion of the date from a Date or TimeStamp value.
InterBase Express
InterBase Express for InterBase 6 adds a new InterBase Admin tab to the Component palette. The Admin tab contains 11 new components that provide an interface to the new InterBase Service, Install, and Licensing APIs. With these components, you can install InterBase or the InterBase client, and administer every aspect of your InterBase server and database.
The IBBackupService and IBRestoreService components allow you to back up and restore InterBase databases, on a client machine or on the database server. Using the IBConfigService component you can start and stop the InterBase service and determine if the service is running. You can also shut down a database, or bring a database on line. IBConfigService also provides methods to set all of the parameters of a database, including read-only, the SQL dialect, the number of page buffers, the sweep interval, the asynchronous write mode, and whether space for record versions is automatically reserved in the database pages.
Use the IBValidationService component to validate your database and recover any transactions that are in limbo. The IBStatisticalService reports various statistics about your database. The IBLogService is a handy diagnostic tool that retrieves the contents of the InterBase log file from the server. If you need to add or delete users, or make changes to the security settings for a user, use the IBSecurityService component. The IBLicensingService component lets you add license certificates, and the IBServerProperties component reports server licensing and configuration information. Finally, the IBInstall and IBUninstall components let you easily install or uninstall InterBase from your application.
IBConsole
The most noticeable change in InterBase 6 is that Server Manager and WISQL have been replaced by IBConsole. IBConsole, shown in Figure 1, is a Windows application you can use to administer InterBase servers and databases on any platform. The IBConsole user interface is divided into a tree pane, on the left, and a work pane, on the right. The tree pane provides a view of your InterBase servers, databases, and database objects. Figure 1 shows two servers, each with one database, with all nodes in the tree expanded. The tree pane lets you select and work with servers, databases, backups, license certificates, the server log, and users. For each database you have access to domains, tables, views, stored procedures, external functions (also called user-defined functions), generators, exceptions, BLOB filters, and roles.
Figure 1: The tree pane and work pane of the IBConsole user interface.
You can work with servers and databases in two ways. The easiest way is to right-click the server or database, and make a choice from the context menu. The alternative is to select a server or database, and use the main menu. Before you can work with a server, you must right-click on InterBase Servers, the root entry in the tree pane, and choose Register to register the server. Figure 2 shows the Register Server and Connect dialog box. Simply enter the server's name, choose a network protocol, enter an alias for the server (which will appear in the tree view) and enter a user name and password. Click OK and the server will appear in the tree pane. Right-click on the server to register an existing database or create a new one.
Figure 2: The Register Server and Connect dialog box.
What appears in the work pane depends on what you select in the tree pane. Figure 3 shows the work pane with a database selected. The items in the work pane offer most of the same options you will see on the context menu, if you right-click the database in the tree pane. To perform any task in the work pane, simply double-click it.
Figure 3: The work pane with a database selected.
When you expand a database you can double-click on Domains, Tables, Views, Stored Procedures, External Functions, Generators, Exceptions, Blob Filters, or Roles. Figure 4 shows the result of double-clicking the Customer table. The Properties tab lets you see the structure of the table, and the Metadata tab shows the CREATE TABLE statement for the table. Permissions lists all users with access to the table and their rights. Using the Data tab you can browse the table's data, and Dependencies lists any objects in the database that depend on the table. Double-clicking on other database objects displays similar information.
Figure 4: The properties of a table.
Unfortunately, most of the information displayed in IBConsole is read-only. To make changes you must still write your own SQL. Click the SQL toolbar button, or choose Tools | Interactive SQL from the menu to open the SQL Editor shown in Figure 5. The top pane shows your SQL script. You can enter your SQL from the keyboard, or load an existing SQL script and execute it. Any SQL you enter can also be saved as a script file. The bottom pane shows the result of executing the script, or, if the script includes a SELECT statement, the bottom pane displays the returned data.
Figure 5: The SQL editor.
Replication
With InterBase 6 you can replicate a source database to any number of target databases. The targets can have different table structures and different column names. You can replicate different tables, rows, and columns to each target database.
Replication can be initiated by a request from a client application, at timed intervals configured in the replication scheduler, or by an InterBase event. You can also use synchronous replication to propagate each change to the target database(s) as soon as it occurs.
Replication would be simple if the source database was the only one being changed. However, if both the source and target databases are being changed, some mechanism must be provided to resolve conflicts. Conflict resolution can be configured to any of three modes. Using priority-based resolution, the database with the highest priority takes precedence. Suppose the source database has the highest priority. In this case, an update to a record that doesn't exist in the target is automatically converted to an insert. An insert where the target already contains a record with the same primary key is converted to an update. A delete where the record doesn't exist in the target is ignored. Using time-stamped resolution, the change with the latest timestamp has precedence. Using master/slave resolution, the source database takes precedence.
For each source/target database pair you must create a configuration database using the Replication Manager, as shown in Figure 6. While this is a bit more work if the replication and structure is identical for all of the targets, it provides virtually infinite flexibility if they are not. The next step is to add the source and target databases using the Databases tab of the Replication Manager's main form (see Figure 7).
Figure 6: The Replication Manager's Configuration databases form.
Figure 7: Adding databases in the Replication Manager.
Use the Replication Manager's Replications page, shown in Figure 8, to create the replication schemata. The schemata identifies the source and target databases and the tables, rows, and columns that will be replicated. The final step is to double-click the Create system objects icon in the Replication Manager's control panel at the right side of the form. This step automatically creates the log table and stored procedures required for replication in the source database. Note that no changes are made to the target database.
Figure 8: The Replications page of the Replication Manager.
Read-only Databases
InterBase 6 databases have two modes: read-write and read-only. All databases are created in read-write mode, but can be changed to read-only using gbak, gfix, or IBConsole. Once a database has been changed to read-only mode you can copy it to a CD-ROM, or any other read-only media, and access the data. The only restrictions are that you cannot change the data or metadata, and you can only access generators to get their current value. For example:
SELECT GEN_ID(EMP_NO_GEN, 0) FROM EMPLOYEE
will work, and will return the current value of the EMP_NO_GEN generator. However:
SELECT GEN_ID(EMP_NO_GEN, 1) FROM EMPLOYEE
will fail because the generator cannot be incremented. To make a database read-only using IBConsole, right-click the database and choose Properties from the context menu to display the Database Properties dialog box shown in Figure 9. Click Read Only, then click the drop-down arrow and choose True. Finally, click the Apply button to change the mode to read-only. To change the mode with gbak, back up the database, then restore it in read-only mode using the following command:
gbak -create -mode read-only employee.gbk employee.gdb
To change the mode using gfix use the following command:
gfix -mode read_only employee.gdb
To change the mode to read-only or read-write, you must be the owner of the database or sysdba, and you must have exclusive use of the database.
Figure 9: The Database Properties dialog box.
ALTER TABLE and ALTER DOMAIN
The SQL ALTER TABLE statement now allows you to change the name, data type, or position of an existing column in a table. For example:
ALTER TABLE CUSTOMER
ALTER POSTAL_CODE TO ZIP_CODE
will change the name of the POSTAL_CODE field to ZIP_CODE, and:
ALTER TABLE CUSTOMER
ALTER POSTAL_CODE TYPE VARCHAR(14)
will change the data type to VARCHAR(14). In InterBase 6, ALTER DOMAIN also lets you change the type of a domain.
GBAK
The gbak utility now includes the functionality provided by gsplit in InterBase 5, allowing you to back up to multiple files in a single step. The new -service switch lets you run a back up on the server, without copying the data across the network to the client. This can mean substantially faster backups with less network traffic load.
Conclusion
InterBase 6 is a major upgrade. With the addition of large exact numerics, replication, and the InterBase Express Admin tools, you now have a full-featured SQL database server - available at no cost - that lets you create BDE-free database applications that support any requirement from a single user, with a modest amount of data to hundreds of users with many gigabytes of data distributed across multiple databases. It's even a great database for over-the-counter software that requires a large database on a CD-ROM.
InterBase 6 will be available from http://www.interbase.com/. Packaged CD editions will follow shortly thereafter. Editions with printed documentation will cost more.
Sets to Strings, and Back
Problem/Question/Abstract:
Employing Sets, Strings, and Run-type Type Information
Answer:
A frequently asked question is: "How can I store a font style in the registry?" You have a number of choices; one approach is to convert the style to a string and store the string. You'll then need to convert the string back to a font style when loading the information from the registry. It's easy to hard-wire a couple of functions to do this for font styles, but it would be more useful to write general-purpose subroutines that work for any set. This article shows you how to take advantage of Delphi's Run-time Type Information (RTTI) to write functions that do just that: convert any set to a string and back again.
About RTTI
RTTI lies at the heart of Delphi's integrated development environment. The difference between a public property, method, or field, and a published one, is that published declarations have RTTI information that is available at run time. The Object Inspector uses RTTI for published properties to help it get and set property values. The form designer uses RTTI for published fields to define a field for each component you drop on a form.
RTTI also lets Delphi manage the lifetime of strings, dynamic arrays, interfaces, and variants. Even if you declare a dynamic array of strings in a record, for example, Delphi can navigate RTTI for the record, array, and string types to decide when it must initialize and finalize the strings and the dynamic array.
A set's RTTI contains a pointer to RTTI for the type that makes up the components of the set - usually an enumerated type, but it can also be an integer or character type. This article examines in depth RTTI for a set type. If you have the Professional or Enterprise Edition, you can read the source code in \Source\Vcl\TypInfo.pas; if you have the Standard Edition, read the interface in \Doc\TypInfo.int. Either file contains the information you need to make sense of RTTI.
A type's RTTI has two parts: type information and type data. The type information is stored in a TTypeInfo record, which contains a type kind and the type's name. The type kind is an enumeration of the various kinds of types in Delphi: tkInteger, tkChar, tkEnumeration, tkSet, and so on. The type kinds are self-explanatory. The built-in TypeInfo function returns a pointer to a type's TTypeInfo record.
TTypeData stores the type data in a variant record. Each type kind refers to different members of the record. For example, tkSet has a pointer to a PTypeInfo for the component type. Ordinal types have the MinValue and MaxValue members to store the range of values defined for the type. See the declaration in TypInfo.pas (or TypInfo.int) for the details of other types' data. If an ordinal type is declared as a subrange of another type, the type data's BaseType member points to the PTypeInfo for the base enumerated type.
Note that the pointers in TypeInfo all use two levels of indirection. For example, a TTypeData member might have the type PPTypeInfo instead of PTypeInfo (that is, pointer to pointer to TTypeInfo instead of a simple pointer to TTypeInfo). If you use packages, the type information for different types can reside in different packages. The extra level of pointers makes it easy for Windows to load the package DLL at any starting address and fix up RTTI pointers.
Sets in Delphi
Delphi stores a set value as a bit mask. A set can contain up to 256 elements, which requires a bitmask with 256 bits. At eight bits per byte, that means the largest possible set occupies 32 bytes. Delphi uses only as many bytes as it needs, so a set of up to eight elements usually fits in a single byte. For example, TFontStyles is a set with up to four members, occupying bits 0 through 3. Delphi ignores the most significant four bits in the byte because they aren't needed. Figure 1 illustrates the arrangement of bits in a byte.
Figure 1: Bit representation of TFontStyles.
I wrote "usually" in the previous paragraph because sets of integers or characters aren't always aligned on byte boundaries. Delphi stores sets so that a member's bit position is always the same for a given ordinal value. In other words, ordinal value 10 always sits at the third bit from the right in a byte. If the set type is, say, "set of 7..10", Delphi stores that set in two bytes, even though it fits in only four bits. The last bit of the first byte stores member 7, and the first three bits of the next byte store members 8, 9, and 10, as shown in Figure 2. This representation of sets results in compact storage and code, and makes it easy to assign set values and test set membership.
Figure 2: Bit representation of an integer set.
This representation for sets also makes it possible to write general-purpose subroutines that can handle any set. The subroutines need RTTI for the set type. The set type's component type specifies the MinValue and MaxValue for the ordinal type, and those values dictate the bitwise representation for the set. Delphi restricts the members of a set to ordinal values in the range 0..255, which means you can treat any set as a set of integers where the integers are a subrange of 0..255. For example, TFontStyles is equivalent to a set of 0..3, where 0 is the ordinal value of fsBold, 1 is fsItalic, and so on. The functions described in this article rely on this trick: Every set is treated as a set of integers, using Run-time Type Information to learn the true enumerated literal for each set member.
SetToString Function
The first - and easier - task is to convert a set to a string. The SetToString function requires the PTypeInfo pointer for the set type, and the set value. To write a subroutine that takes any set as an argument, it must use an untyped parameter to get around Delphi's strict type checking. The function's header is as follows:
function SetToString(Info: PTypeInfo; const Value): string;
To give the caller control over the formatting, overloaded functions take additional parameters for prefix, separator, and suffix strings. (Note that SetToString uses overloaded functions instead of default parameter values. When you have string parameters, you should use overloaded subroutines. Otherwise, every use of the default string parameter results in a separate copy of the string. Using overloaded subroutines avoids the additional overhead of multiple copies of the same string.)
SetToString is a fairly simple function; it iterates over all possible members of the set, tests the bit for that member, and adds the member's literal representation to the Result string if the member is present in the set. Figure 3 shows a first draft of this overloaded function.
const
MaxSet = 255; // Largest ordinal value in a Delphi set.
BitsPerByte = 8;
type
TSet = set of 0..MaxSet;
function SetToString(Info: PTypeInfo; const Value):
string; overload;
begin
Result := SetToString(Info, Value, ',');
end;
function SetToString(Info: PTypeInfo; const Value;
const Separator: string): string; overload;
begin
Result := SetToString(Info, Value, Separator, '[', ']');
end;
function SetToString(Info: PTypeInfo; const Value;
const Separator, Prefix, Suffix: string):
string; overload;
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
Element: 0..MaxSet;
begin
CompInfo := GetTypeData(Info)^.CompType^;
CompData := GetTypeData(CompInfo);
Result := '';
for Element := CompData.MinValue to CompData.MaxValue do
begin
if Element in SetValue then
if Result = '' then
Result := Prefix + GetEnumName(CompInfo, Element)
else
Result := Result + Separator +
GetEnumName(CompInfo, Element);
end;
if Result = '' then
Result := Prefix + Suffix
else
Result := Result + Suffix;
end;
Figure 3: First, simple implementation of SetToString.
The GetEnumName function is one of Delphi's standard functions in the TypeInfo unit. It takes an ordinal value, and returns a string literal. If the type is an enumerated type, GetEnumName returns the enumerated literal. If the type is an integer type, the function calls IntToStr to convert the number to a string.
If the set type is a set of characters, though, GetEnumName doesn't work correctly. It doesn't test the type kind, so the result is unpredictable - usually an access violation. To solve this problem, write a function that does the same thing, but support characters, integers, and enumerations. Figure 4 shows the OrdToString function.
// Convert an ordinal value to a string. The ordinal value
// can be an integer, enumerated value, or a character.
function OrdToString(Info: PTypeInfo; Value: Integer):
string;
resourcestring
sCvtError =
'OrdToString: type kind must be ordinal, not %s';
const
AsciiChars = [32..127]; // Printable ASCII characters.
begin
case Info.Kind of
tkInteger:
Result := IntToStr(Value);
tkChar, tkWChar:
if Value in AsciiChars then
Result := '''' + Chr(Value) + ''''
else
Result := Format('#%d', [Value]);
tkEnumeration:
Result := GetEnumName(Info, Value);
else
raise EConvertError.CreateFmt(sCvtError,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
end;
end;
Figure 4: OrdToString converts any ordinal value to a string.
You may have noticed another problem with SetToString. Consider the case of an integer or character set whose first member doesn't have ordinal value 0. The function tests the wrong bit in the set. To handle this case, the function must find the correct bit position. If the first member of the set falls after a byte boundary, Delphi saves space and doesn't store the initial empty bytes. SetToString must handle this case too.
Finally, the function checks the type info to make sure the type is a set type (type kind of tkSet). If not, it raises an exception. Figure 5 lists the final version of SetToString.
resourcestring
sNotASet = 'SetToString: argument must be a ' +
'set type; %s not allowed';
const
// Mask to force the minimum set value to be
// a set element on a byte boundary.
ByteBoundaryMask = not (BitsPerByte - 1);
function SetToString(Info: PTypeInfo; const Value;
const Separator, Prefix, Suffix: string): string;
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
Element: 0..MaxSet;
MinElement: 0..MaxSet;
begin
if Info.Kind <> tkSet then
raise EConvertError.CreateFmt(sNotASet,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
CompInfo := GetTypeData(Info)^.CompType^;
CompData := GetTypeData(CompInfo);
Result := '';
MinElement := CompData.MinValue and ByteBoundaryMask;
for Element := CompData.MinValue to CompData.MaxValue do
begin
if (Element - MinElement) in SetValue then
if Result = '' then
Result := Prefix + OrdToString(CompInfo, Element)
else
Result := Result + Separator +
OrdToString(CompInfo, Element);
end;
if Result = '' then
Result := Prefix + Suffix
else
Result := Result + Suffix;
end;
Figure 5: Final version of SetToString.
StringToSet Function
More difficult is the task of converting a string to a set. The string might use any prefix, suffix, and separator characters; it might contain space characters. The string might not be correctly formed. A string can contain enumerated literals, integers, or characters. Characters have multiple representations as well: quotes ('x'), ordinal value (#13), or control character (^M).
Characters are sufficiently different from integers and enumerations that two functions are needed. StringToSet calls StringToEnumSet or StringToCharSet, depending on the type kind of the set's component type. Before it converts the string, though, it must initialize the set to empty. The size of the set's value is independent of the type, so StringToSet initializes the set to empty by calling FillChar. The size of the set depends on the limits of the component type, which must be rounded to byte boundaries. Figure 6 shows the StringToSet function.
procedure StringToSet(const Str: string;
Info: PTypeInfo; var Value);
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
MinValue, MaxValue: Integer;
begin
if Info.Kind <> tkSet then
raise EConvertError.CreateFmt(sNotASet,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
CompInfo := GetTypeData(Info)^.CompType^;
// Initialize SetValue to an empty set. Only initialize
// as many bytes as are present in the set.
CompData := GetTypeData(CompInfo);
MinValue := CompData.MinValue and ByteBoundaryMask;
MaxValue := (CompData.MaxValue + BitsPerByte - 1) and
ByteBoundaryMask;
FillChar(SetValue, (MaxValue - MinValue) div BitsPerByte, 0);
if CompInfo.Kind in [tkChar, tkWChar] then
StringToCharSet(Str, CompData, SetValue)
else
StringToEnumSet(Str, CompInfo, CompData, SetValue);
end;
Figure 6: StringToSet divides its work between StringToEnumSet and StringToCharSet.
Starting with StringToEnumSet (because it's simpler), the first task is to skip over leading white space characters, then look for a prefix character. Any non-alphanumeric character is allowed as a prefix, but it must be only one character. SetToString allows any string, but StringToSet must be a little more restrictive to keep it manageable. Then, the function skips more white space and collects an alphanumeric token.
The TypeInfo unit has the GetEnumValue function to convert an enumerated literal to its ordinal value. Like GetEnumName, it doesn't handle character types. StringToEnumSet doesn't handle sets of characters either, so StringToEnumSet can call GetEnumValue. GetEnumValue raises an EConvertError exception if the type is an integer type and the string is not a valid integer. It returns -1 for an enumerated type when the name is not valid for the type. StringToEnumSet checks for a negative value indicating an error from GetEnumValue. It also checks to ensure the ordinal value is in range for the set's type. For any error, it raises an EConvertError exception.
StringToEnumSet must find the correct bit position in the set, in the same manner as SetToString. Once it finds that position, it sets the bit to one, and continues its loop. The next time through the loop, a non-alphanumeric character can be a separator between set elements. The final loop looks for a trailing non-alphanumeric character as the suffix. If the string cannot be parsed, the function raises an exception. Figure 7 lists StringToEnumSet.
const
WhiteSpace = [#0..' '];
Alphabetic = ['a'..'z', 'A'..'Z', '_'];
Digits = ['0'..'9'];
AlphaNumeric = Alphabetic + Digits;
resourcestring
sInvalidSetString =
'StringToSet: %s not a valid literal for the set type';
sOutOfRange =
'StringToSet: %0:d is out of range [%1:d..%2:d]';
procedure SkipWhiteSpace(const Str: string;
var I: Integer);
begin
while (I <= Length(Str)) and (Str[I] in WhiteSpace) do
Inc(I);
end;
procedure StringToEnumSet(const Str: string;
CompInfo: PTypeInfo; CompData: PTypeData;
var Value: TSet);
var
ElementName: string;
Element: Integer;
MinElement: Integer;
Start: Integer;
I: Integer;
begin
MinElement := CompData.MinValue and ByteBoundaryMask;
I := 1;
while I <= Length(Str) do
begin
SkipWhiteSpace(Str, I);
// Skip the prefix, separator, or suffix.
if (I <= Length(Str)) and
not (Str[I] in AlphaNumeric) then
Inc(I);
SkipWhiteSpace(Str, I);
// Remember the start of the set element,
// and collect the entire element name.
Start := I;
while (I <= Length(Str)) and (Str[I] in AlphaNumeric) do
Inc(I);
// No name, so skip to the next element.
if I = Start then
Continue;
ElementName := Copy(Str, Start, I - Start);
Element := GetEnumValue(CompInfo, ElementName);
if Element < 0 then
raise EConvertError.CreateFmt(sInvalidSetString,
[AnsiQuotedStr(ElementName, '''')]);
if (Element < CompData.MinValue) or
(Element > CompData.MaxValue) then
raise EConvertError.CreateFmt(sOutOfRange,
[Element, CompData.MinValue, CompData.MaxValue]);
Include(Value, Element - MinElement);
end;
end;
Figure 7: The StringToEnumSet function.
Converting a string to a character set is harder, because parsing the characters is more involved. The basic structure of StringToCharSet is the same as StringToEnumSet, except that each set element must be a character. StringToCharSet supports quoted characters and ordinal values after a number sign (#127), which are the same formats used by SetToString. Note that Delphi supports one other way to specify characters: A caret followed by a character can be used for control characters (^M). However, SetToString doesn't use that format, so StringToCharSet doesn't either.
A quoted character can be a repeated quote (''''). An ordinal value can be decimal or hexadecimal (starting with a dollar sign, as per Delphi conventions). The details of parsing characters aren't relevant to this article, so check out Listing One for the full story.
Putting It All Together
Now that you have the SetToString and StringToSet functions, you need to put them to good use. For example, if you want to store font information in the registry, you can store the font name as a string, the size as an integer, and convert the style to a string, as shown in Figure 8. Because the Value parameter is untyped, you cannot pass a property directly to SetToString or StringToSet, so you must use a temporary variable. If the font style is, say, fsBold and fsItalic, the registry would contain the string [fsBold,fsItalic].
procedure SaveFont(Font: TFont; Reg: TRegistry);
var
Style: TFontStyles;
begin
Reg.WriteString('Name', Font.Name);
Reg.WriteInteger('Size', Font.Size);
Style := Font.Style;
Reg.WriteString('Style',
SetToString(TypeInfo(TFontStyles), Style));
end;
procedure LoadFont(Font: TFont; Reg: TRegistry);
var
Style: TFontStyles;
begin
Font.Name := Reg.ReadString('Name');
Font.Size := Reg.WriteInteger('Size');
StringToSet(Reg.ReadString('Style'),
TypeInfo(TFontStyles), Style);
Font.Style := Style;
end;
Figure 8: Saving a font in the registry.
The Object Inspector already uses a function similar to SetToString to display the value of a set-type property. You can write your own property editor for set-type properties and call SetToString. You can even let the user type a new set value and call StringToSet - something Delphi doesn't currently allow.
Conclusion
The SetToString and StringToSet functions work with any set of any type, thanks to the wonders of Run-time Type Information. How you use these functions is up to you.
The project referenced in this article is available for downloadhttp://www.baltsoft.com/files/dkb/attachment/setstring.zip.
Begin Listing One -StringToCharSet
const
Digits = ['0'..'9'];
HexDigits = ['a'..'f', 'A'..'F'] + Digits;
CharBegin = ['#', ''''];
AsciiChars = [' '..'~']; // Printable ASCII characters.
resourcestring
sNotAChar =
'StringToSet: Not a valid character (%.10s)';
sCharOutOfRange =
'StringToSet: Character #%0:d is ' +
'out of range [#%1:d..#%2:d]';
// Convert a string to a set of character elements.
procedure StringToCharSet(const Str: string;
CompData: PTypeData; var Value: TSet);
var
ElementName: string;
Element: Integer;
MinElement: Integer;
Start: Integer;
I: Integer;
begin
MinElement := CompData.MinValue and ByteBoundaryMask;
I := 1;
while I <= Length(Str) do
begin
SkipWhiteSpace(Str, I);
// Skip over one character, which might be the prefix,
// a separator, or suffix.
if (I <= Length(Str)) and not (Str[I] in CharBegin) then
Inc(I);
SkipWhiteSpace(Str, I);
if I > Length(Str) then
Break;
case Str[I] of
'#':
begin
// Character is specified by ordinal value,
// e.g. #31 or #$A2.
Inc(I);
Start := I;
if (I < Length(Str)) and (Str[I] = '$') then
begin
Inc(I);
while (I <= Length(Str)) and
(Str[I] in HexDigits) do
Inc(I);
end
else
begin
while (I <= Length(Str)) and
(Str[I] in Digits) do
Inc(I);
end;
ElementName := Copy(Str, Start, I - Start);
Element := StrToInt(ElementName);
end;
'''':
begin
// Character is enclosed in quotes, e.g. 'A'.
Start := I; // Save position for error messages.
Inc(I);
if (I <= Length(Str)) then
begin
Element := Ord(Str[I]);
if Str[I] = '''' then
// Skip over a repeated quote character.
Inc(I);
// Skip to the closing quote.
Inc(I);
end;
if (I <= Length(Str)) and (Str[I] = '''') then
Inc(I)
else
raise EConvertError.CreateFmt(sNotAChar,
[Copy(Str, Start, I - Start)]);
end;
else
// The unknown character might be the suffix. Try
// skipping it and subsequent white space. Save the
// original index in case the suffix-test fails.
Start := I;
Inc(I);
SkipWhiteSpace(Str, I);
if I <= Length(Str) then
raise EConvertError.CreateFmt(sNotAChar,
[Copy(Str, Start, I - Start)])
else
Exit;
end;
if (Element < CompData.MinValue) or
(Element > CompData.MaxValue) then
raise EConvertError.CreateFmt(sCharOutOfRange,
[Element, CompData.MinValue, CompData.MaxValue]);
Include(Value, Element - MinElement);
end;
end;
End Listing One
Employing Sets, Strings, and Run-type Type Information
Answer:
A frequently asked question is: "How can I store a font style in the registry?" You have a number of choices; one approach is to convert the style to a string and store the string. You'll then need to convert the string back to a font style when loading the information from the registry. It's easy to hard-wire a couple of functions to do this for font styles, but it would be more useful to write general-purpose subroutines that work for any set. This article shows you how to take advantage of Delphi's Run-time Type Information (RTTI) to write functions that do just that: convert any set to a string and back again.
About RTTI
RTTI lies at the heart of Delphi's integrated development environment. The difference between a public property, method, or field, and a published one, is that published declarations have RTTI information that is available at run time. The Object Inspector uses RTTI for published properties to help it get and set property values. The form designer uses RTTI for published fields to define a field for each component you drop on a form.
RTTI also lets Delphi manage the lifetime of strings, dynamic arrays, interfaces, and variants. Even if you declare a dynamic array of strings in a record, for example, Delphi can navigate RTTI for the record, array, and string types to decide when it must initialize and finalize the strings and the dynamic array.
A set's RTTI contains a pointer to RTTI for the type that makes up the components of the set - usually an enumerated type, but it can also be an integer or character type. This article examines in depth RTTI for a set type. If you have the Professional or Enterprise Edition, you can read the source code in \Source\Vcl\TypInfo.pas; if you have the Standard Edition, read the interface in \Doc\TypInfo.int. Either file contains the information you need to make sense of RTTI.
A type's RTTI has two parts: type information and type data. The type information is stored in a TTypeInfo record, which contains a type kind and the type's name. The type kind is an enumeration of the various kinds of types in Delphi: tkInteger, tkChar, tkEnumeration, tkSet, and so on. The type kinds are self-explanatory. The built-in TypeInfo function returns a pointer to a type's TTypeInfo record.
TTypeData stores the type data in a variant record. Each type kind refers to different members of the record. For example, tkSet has a pointer to a PTypeInfo for the component type. Ordinal types have the MinValue and MaxValue members to store the range of values defined for the type. See the declaration in TypInfo.pas (or TypInfo.int) for the details of other types' data. If an ordinal type is declared as a subrange of another type, the type data's BaseType member points to the PTypeInfo for the base enumerated type.
Note that the pointers in TypeInfo all use two levels of indirection. For example, a TTypeData member might have the type PPTypeInfo instead of PTypeInfo (that is, pointer to pointer to TTypeInfo instead of a simple pointer to TTypeInfo). If you use packages, the type information for different types can reside in different packages. The extra level of pointers makes it easy for Windows to load the package DLL at any starting address and fix up RTTI pointers.
Sets in Delphi
Delphi stores a set value as a bit mask. A set can contain up to 256 elements, which requires a bitmask with 256 bits. At eight bits per byte, that means the largest possible set occupies 32 bytes. Delphi uses only as many bytes as it needs, so a set of up to eight elements usually fits in a single byte. For example, TFontStyles is a set with up to four members, occupying bits 0 through 3. Delphi ignores the most significant four bits in the byte because they aren't needed. Figure 1 illustrates the arrangement of bits in a byte.
Figure 1: Bit representation of TFontStyles.
I wrote "usually" in the previous paragraph because sets of integers or characters aren't always aligned on byte boundaries. Delphi stores sets so that a member's bit position is always the same for a given ordinal value. In other words, ordinal value 10 always sits at the third bit from the right in a byte. If the set type is, say, "set of 7..10", Delphi stores that set in two bytes, even though it fits in only four bits. The last bit of the first byte stores member 7, and the first three bits of the next byte store members 8, 9, and 10, as shown in Figure 2. This representation of sets results in compact storage and code, and makes it easy to assign set values and test set membership.
Figure 2: Bit representation of an integer set.
This representation for sets also makes it possible to write general-purpose subroutines that can handle any set. The subroutines need RTTI for the set type. The set type's component type specifies the MinValue and MaxValue for the ordinal type, and those values dictate the bitwise representation for the set. Delphi restricts the members of a set to ordinal values in the range 0..255, which means you can treat any set as a set of integers where the integers are a subrange of 0..255. For example, TFontStyles is equivalent to a set of 0..3, where 0 is the ordinal value of fsBold, 1 is fsItalic, and so on. The functions described in this article rely on this trick: Every set is treated as a set of integers, using Run-time Type Information to learn the true enumerated literal for each set member.
SetToString Function
The first - and easier - task is to convert a set to a string. The SetToString function requires the PTypeInfo pointer for the set type, and the set value. To write a subroutine that takes any set as an argument, it must use an untyped parameter to get around Delphi's strict type checking. The function's header is as follows:
function SetToString(Info: PTypeInfo; const Value): string;
To give the caller control over the formatting, overloaded functions take additional parameters for prefix, separator, and suffix strings. (Note that SetToString uses overloaded functions instead of default parameter values. When you have string parameters, you should use overloaded subroutines. Otherwise, every use of the default string parameter results in a separate copy of the string. Using overloaded subroutines avoids the additional overhead of multiple copies of the same string.)
SetToString is a fairly simple function; it iterates over all possible members of the set, tests the bit for that member, and adds the member's literal representation to the Result string if the member is present in the set. Figure 3 shows a first draft of this overloaded function.
const
MaxSet = 255; // Largest ordinal value in a Delphi set.
BitsPerByte = 8;
type
TSet = set of 0..MaxSet;
function SetToString(Info: PTypeInfo; const Value):
string; overload;
begin
Result := SetToString(Info, Value, ',');
end;
function SetToString(Info: PTypeInfo; const Value;
const Separator: string): string; overload;
begin
Result := SetToString(Info, Value, Separator, '[', ']');
end;
function SetToString(Info: PTypeInfo; const Value;
const Separator, Prefix, Suffix: string):
string; overload;
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
Element: 0..MaxSet;
begin
CompInfo := GetTypeData(Info)^.CompType^;
CompData := GetTypeData(CompInfo);
Result := '';
for Element := CompData.MinValue to CompData.MaxValue do
begin
if Element in SetValue then
if Result = '' then
Result := Prefix + GetEnumName(CompInfo, Element)
else
Result := Result + Separator +
GetEnumName(CompInfo, Element);
end;
if Result = '' then
Result := Prefix + Suffix
else
Result := Result + Suffix;
end;
Figure 3: First, simple implementation of SetToString.
The GetEnumName function is one of Delphi's standard functions in the TypeInfo unit. It takes an ordinal value, and returns a string literal. If the type is an enumerated type, GetEnumName returns the enumerated literal. If the type is an integer type, the function calls IntToStr to convert the number to a string.
If the set type is a set of characters, though, GetEnumName doesn't work correctly. It doesn't test the type kind, so the result is unpredictable - usually an access violation. To solve this problem, write a function that does the same thing, but support characters, integers, and enumerations. Figure 4 shows the OrdToString function.
// Convert an ordinal value to a string. The ordinal value
// can be an integer, enumerated value, or a character.
function OrdToString(Info: PTypeInfo; Value: Integer):
string;
resourcestring
sCvtError =
'OrdToString: type kind must be ordinal, not %s';
const
AsciiChars = [32..127]; // Printable ASCII characters.
begin
case Info.Kind of
tkInteger:
Result := IntToStr(Value);
tkChar, tkWChar:
if Value in AsciiChars then
Result := '''' + Chr(Value) + ''''
else
Result := Format('#%d', [Value]);
tkEnumeration:
Result := GetEnumName(Info, Value);
else
raise EConvertError.CreateFmt(sCvtError,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
end;
end;
Figure 4: OrdToString converts any ordinal value to a string.
You may have noticed another problem with SetToString. Consider the case of an integer or character set whose first member doesn't have ordinal value 0. The function tests the wrong bit in the set. To handle this case, the function must find the correct bit position. If the first member of the set falls after a byte boundary, Delphi saves space and doesn't store the initial empty bytes. SetToString must handle this case too.
Finally, the function checks the type info to make sure the type is a set type (type kind of tkSet). If not, it raises an exception. Figure 5 lists the final version of SetToString.
resourcestring
sNotASet = 'SetToString: argument must be a ' +
'set type; %s not allowed';
const
// Mask to force the minimum set value to be
// a set element on a byte boundary.
ByteBoundaryMask = not (BitsPerByte - 1);
function SetToString(Info: PTypeInfo; const Value;
const Separator, Prefix, Suffix: string): string;
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
Element: 0..MaxSet;
MinElement: 0..MaxSet;
begin
if Info.Kind <> tkSet then
raise EConvertError.CreateFmt(sNotASet,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
CompInfo := GetTypeData(Info)^.CompType^;
CompData := GetTypeData(CompInfo);
Result := '';
MinElement := CompData.MinValue and ByteBoundaryMask;
for Element := CompData.MinValue to CompData.MaxValue do
begin
if (Element - MinElement) in SetValue then
if Result = '' then
Result := Prefix + OrdToString(CompInfo, Element)
else
Result := Result + Separator +
OrdToString(CompInfo, Element);
end;
if Result = '' then
Result := Prefix + Suffix
else
Result := Result + Suffix;
end;
Figure 5: Final version of SetToString.
StringToSet Function
More difficult is the task of converting a string to a set. The string might use any prefix, suffix, and separator characters; it might contain space characters. The string might not be correctly formed. A string can contain enumerated literals, integers, or characters. Characters have multiple representations as well: quotes ('x'), ordinal value (#13), or control character (^M).
Characters are sufficiently different from integers and enumerations that two functions are needed. StringToSet calls StringToEnumSet or StringToCharSet, depending on the type kind of the set's component type. Before it converts the string, though, it must initialize the set to empty. The size of the set's value is independent of the type, so StringToSet initializes the set to empty by calling FillChar. The size of the set depends on the limits of the component type, which must be rounded to byte boundaries. Figure 6 shows the StringToSet function.
procedure StringToSet(const Str: string;
Info: PTypeInfo; var Value);
var
CompInfo: PTypeInfo;
CompData: PTypeData;
SetValue: TSet absolute Value;
MinValue, MaxValue: Integer;
begin
if Info.Kind <> tkSet then
raise EConvertError.CreateFmt(sNotASet,
[GetEnumName(TypeInfo(TTypeKind), Ord(Info.Kind))]);
CompInfo := GetTypeData(Info)^.CompType^;
// Initialize SetValue to an empty set. Only initialize
// as many bytes as are present in the set.
CompData := GetTypeData(CompInfo);
MinValue := CompData.MinValue and ByteBoundaryMask;
MaxValue := (CompData.MaxValue + BitsPerByte - 1) and
ByteBoundaryMask;
FillChar(SetValue, (MaxValue - MinValue) div BitsPerByte, 0);
if CompInfo.Kind in [tkChar, tkWChar] then
StringToCharSet(Str, CompData, SetValue)
else
StringToEnumSet(Str, CompInfo, CompData, SetValue);
end;
Figure 6: StringToSet divides its work between StringToEnumSet and StringToCharSet.
Starting with StringToEnumSet (because it's simpler), the first task is to skip over leading white space characters, then look for a prefix character. Any non-alphanumeric character is allowed as a prefix, but it must be only one character. SetToString allows any string, but StringToSet must be a little more restrictive to keep it manageable. Then, the function skips more white space and collects an alphanumeric token.
The TypeInfo unit has the GetEnumValue function to convert an enumerated literal to its ordinal value. Like GetEnumName, it doesn't handle character types. StringToEnumSet doesn't handle sets of characters either, so StringToEnumSet can call GetEnumValue. GetEnumValue raises an EConvertError exception if the type is an integer type and the string is not a valid integer. It returns -1 for an enumerated type when the name is not valid for the type. StringToEnumSet checks for a negative value indicating an error from GetEnumValue. It also checks to ensure the ordinal value is in range for the set's type. For any error, it raises an EConvertError exception.
StringToEnumSet must find the correct bit position in the set, in the same manner as SetToString. Once it finds that position, it sets the bit to one, and continues its loop. The next time through the loop, a non-alphanumeric character can be a separator between set elements. The final loop looks for a trailing non-alphanumeric character as the suffix. If the string cannot be parsed, the function raises an exception. Figure 7 lists StringToEnumSet.
const
WhiteSpace = [#0..' '];
Alphabetic = ['a'..'z', 'A'..'Z', '_'];
Digits = ['0'..'9'];
AlphaNumeric = Alphabetic + Digits;
resourcestring
sInvalidSetString =
'StringToSet: %s not a valid literal for the set type';
sOutOfRange =
'StringToSet: %0:d is out of range [%1:d..%2:d]';
procedure SkipWhiteSpace(const Str: string;
var I: Integer);
begin
while (I <= Length(Str)) and (Str[I] in WhiteSpace) do
Inc(I);
end;
procedure StringToEnumSet(const Str: string;
CompInfo: PTypeInfo; CompData: PTypeData;
var Value: TSet);
var
ElementName: string;
Element: Integer;
MinElement: Integer;
Start: Integer;
I: Integer;
begin
MinElement := CompData.MinValue and ByteBoundaryMask;
I := 1;
while I <= Length(Str) do
begin
SkipWhiteSpace(Str, I);
// Skip the prefix, separator, or suffix.
if (I <= Length(Str)) and
not (Str[I] in AlphaNumeric) then
Inc(I);
SkipWhiteSpace(Str, I);
// Remember the start of the set element,
// and collect the entire element name.
Start := I;
while (I <= Length(Str)) and (Str[I] in AlphaNumeric) do
Inc(I);
// No name, so skip to the next element.
if I = Start then
Continue;
ElementName := Copy(Str, Start, I - Start);
Element := GetEnumValue(CompInfo, ElementName);
if Element < 0 then
raise EConvertError.CreateFmt(sInvalidSetString,
[AnsiQuotedStr(ElementName, '''')]);
if (Element < CompData.MinValue) or
(Element > CompData.MaxValue) then
raise EConvertError.CreateFmt(sOutOfRange,
[Element, CompData.MinValue, CompData.MaxValue]);
Include(Value, Element - MinElement);
end;
end;
Figure 7: The StringToEnumSet function.
Converting a string to a character set is harder, because parsing the characters is more involved. The basic structure of StringToCharSet is the same as StringToEnumSet, except that each set element must be a character. StringToCharSet supports quoted characters and ordinal values after a number sign (#127), which are the same formats used by SetToString. Note that Delphi supports one other way to specify characters: A caret followed by a character can be used for control characters (^M). However, SetToString doesn't use that format, so StringToCharSet doesn't either.
A quoted character can be a repeated quote (''''). An ordinal value can be decimal or hexadecimal (starting with a dollar sign, as per Delphi conventions). The details of parsing characters aren't relevant to this article, so check out Listing One for the full story.
Putting It All Together
Now that you have the SetToString and StringToSet functions, you need to put them to good use. For example, if you want to store font information in the registry, you can store the font name as a string, the size as an integer, and convert the style to a string, as shown in Figure 8. Because the Value parameter is untyped, you cannot pass a property directly to SetToString or StringToSet, so you must use a temporary variable. If the font style is, say, fsBold and fsItalic, the registry would contain the string [fsBold,fsItalic].
procedure SaveFont(Font: TFont; Reg: TRegistry);
var
Style: TFontStyles;
begin
Reg.WriteString('Name', Font.Name);
Reg.WriteInteger('Size', Font.Size);
Style := Font.Style;
Reg.WriteString('Style',
SetToString(TypeInfo(TFontStyles), Style));
end;
procedure LoadFont(Font: TFont; Reg: TRegistry);
var
Style: TFontStyles;
begin
Font.Name := Reg.ReadString('Name');
Font.Size := Reg.WriteInteger('Size');
StringToSet(Reg.ReadString('Style'),
TypeInfo(TFontStyles), Style);
Font.Style := Style;
end;
Figure 8: Saving a font in the registry.
The Object Inspector already uses a function similar to SetToString to display the value of a set-type property. You can write your own property editor for set-type properties and call SetToString. You can even let the user type a new set value and call StringToSet - something Delphi doesn't currently allow.
Conclusion
The SetToString and StringToSet functions work with any set of any type, thanks to the wonders of Run-time Type Information. How you use these functions is up to you.
The project referenced in this article is available for downloadhttp://www.baltsoft.com/files/dkb/attachment/setstring.zip.
Begin Listing One -StringToCharSet
const
Digits = ['0'..'9'];
HexDigits = ['a'..'f', 'A'..'F'] + Digits;
CharBegin = ['#', ''''];
AsciiChars = [' '..'~']; // Printable ASCII characters.
resourcestring
sNotAChar =
'StringToSet: Not a valid character (%.10s)';
sCharOutOfRange =
'StringToSet: Character #%0:d is ' +
'out of range [#%1:d..#%2:d]';
// Convert a string to a set of character elements.
procedure StringToCharSet(const Str: string;
CompData: PTypeData; var Value: TSet);
var
ElementName: string;
Element: Integer;
MinElement: Integer;
Start: Integer;
I: Integer;
begin
MinElement := CompData.MinValue and ByteBoundaryMask;
I := 1;
while I <= Length(Str) do
begin
SkipWhiteSpace(Str, I);
// Skip over one character, which might be the prefix,
// a separator, or suffix.
if (I <= Length(Str)) and not (Str[I] in CharBegin) then
Inc(I);
SkipWhiteSpace(Str, I);
if I > Length(Str) then
Break;
case Str[I] of
'#':
begin
// Character is specified by ordinal value,
// e.g. #31 or #$A2.
Inc(I);
Start := I;
if (I < Length(Str)) and (Str[I] = '$') then
begin
Inc(I);
while (I <= Length(Str)) and
(Str[I] in HexDigits) do
Inc(I);
end
else
begin
while (I <= Length(Str)) and
(Str[I] in Digits) do
Inc(I);
end;
ElementName := Copy(Str, Start, I - Start);
Element := StrToInt(ElementName);
end;
'''':
begin
// Character is enclosed in quotes, e.g. 'A'.
Start := I; // Save position for error messages.
Inc(I);
if (I <= Length(Str)) then
begin
Element := Ord(Str[I]);
if Str[I] = '''' then
// Skip over a repeated quote character.
Inc(I);
// Skip to the closing quote.
Inc(I);
end;
if (I <= Length(Str)) and (Str[I] = '''') then
Inc(I)
else
raise EConvertError.CreateFmt(sNotAChar,
[Copy(Str, Start, I - Start)]);
end;
else
// The unknown character might be the suffix. Try
// skipping it and subsequent white space. Save the
// original index in case the suffix-test fails.
Start := I;
Inc(I);
SkipWhiteSpace(Str, I);
if I <= Length(Str) then
raise EConvertError.CreateFmt(sNotAChar,
[Copy(Str, Start, I - Start)])
else
Exit;
end;
if (Element < CompData.MinValue) or
(Element > CompData.MaxValue) then
raise EConvertError.CreateFmt(sCharOutOfRange,
[Element, CompData.MinValue, CompData.MaxValue]);
Include(Value, Element - MinElement);
end;
end;
End Listing One
Feliratkozás:
Bejegyzések (Atom)