Delphi调用Tuxedo

前言

        本人使用最近在学习tuxedo，前台使用Delphi开发，在网上翻阅了无数的资料，过程曲折，遇到了很多的问题。况且在网上有关Delphi调用Tuxedo的资料也不多，很多问题都要靠自己解决。为了总结自己的学习过程，同时也将相关经验和大家共享，遂有了写这篇文章的冲动。由于本人知识有限，在本文中难免会有错误，还请及时指正。

 

一：Tuxedo安装及配置(Windows)

        1.1 环境

              Tuxedo：Tuxedo8.0

              系统：WindowsXP

              C编译器：Microsoft Visual C++ 6.0

       1.2 安装文件

             Tuxedo: tuxedo80_win.exe（安装文件），R406_TUX80_I-WNT40-2000-XP.exe（补订），Lience（下载地址为：
                            http://www.oracle.com/us/support/licensecodes/bea/index.html，Tuxedo Lience 文件分为SDK和RTK两种，其中SDK为开发Lience,RTK为运行时Lience

　　　　　　　最要使用SDK Lience，如果为RTK Lience则在不能编译程序）。

             VC++: Microsoft Visual C++ 6.0 简体中文企业版

       1.3 Tuxcedo 安装

　　　 1.3.1 安装Tuxedo（全部安装）
                     由于Tuxedo采用的是图形安装界面，用户根据向导就能很容易完成安装，所以下面仅指出一些关键步骤。
              1.3.2 选择安装类型
                     Full Install
              1.3.3 输入监听密码
                     tuxedo
              1.3.4 SSL安装选择
                     no
              1.3.5 License安装选择
                     yes

              1.3.6 安装Tuxedo补丁

        1.4 Tuxedo 配置

　　　　以上Tuxedo的安装路径为C:\tuxedo，Tuxedo服务端程序路径为d:\tuxedoserver，需要配置环境变量，需要设置的环境变量如下。

               1.4.1 修改系统环境变量path的值，增加“C:\tuxedo\tuxedo8.0\bin;”

　　　   1.4.2 在系统变量中增加“APPDIR”项，其值为服务端程序所在路径“d:\tuxedoserver”。

               1.4.3 在系统变量中增加“LIB”项，其值为“C:\tuxedo\tuxedo8.0\lib”，该环境变量在编译tuxedo程序时会用到。

               1.4.4 在系统变量中增加“INCLUDE”项，其值为“C:\tuxedo\tuxedo8.0\include”，该环境变量在编译tuxedo程序时会用到。

               1.4.5 在系统变量中增加“TUXDIR”项，其值为“C:\tuxedo\tuxedo8.0”。

               1.4.6 在系统变量中增加“TUXCONFIG”项，其值为“D:\tuxedoserver\tuxconfig”。该环境变量用来描述服务端程序资源文件名（含路径信息），该文件是二进制文件

                         有ubbconfig文件通过tmloadcf命令编译而来，在tuxedo启动的时候会加载该文件。

               1.4.7 在系统变量中增加“WSNADDR”项，该选项为客户端程序使用，用来描述服务端地址和监听端口号，其值可以为“//192.168.0.102:6565”。服务端的监听端口

　　　　　　和IP地址也在ubbconfig文件中配置“WSL SRVGRP=GROUP1 SRVID=5 CLOPT="-A -t -- -n //192.168.0.102:6565 -m 2 -M 5 -x 10"。服务启动时候会启动监听。

        1.5 Microsoft Visual C++安装

　　　   Tuxedo编译服务端程序（使用buildserver命令编译）和客户端程（使用buildclient命令编译），在编译时需要使用Ｃ编译器，安装VC++的目的是使用其编译器。安装　　的时候要选择设置环境变量。安装完成之后增加环境变量“MSDevDir”项，其值为“C:\Program Files\Microsoft Visual Studio\Common\MSDev98”。

     

       1.6 以上设置完成之后重启系统，重启之后系统变量才会生效。

 

二：tuxedo测试

　 1: 将tuxedo自带的程序simpapp(在C:\tuxedo\tuxedo8.0\samples\atmi\simpapp路径下)，拷贝到d:\tuxedoserver目录下（拷贝simpapp目录下的所有文件）。

　 2: 文件ubbsimple即为tuxedo服务端程序的配置文件（ubbconfig），该文件中记录着服务端程序的所有资源信息，即服务信息，修改如下。

　　

#ident "@(#) apps/simpapp/ubbsimple $Revision: 1.3 $"

#Skeleton UBBCONFIG file for the TUXEDO Simple Application.
#Replace the items with the appropriate values.

*RESOURCES
IPCKEY  123456

#Example:
#IPCKEY  123456

DOMAINID simpapp
MASTER  simple
MAXACCESSERS 100
MAXSERVERS 50
MAXSERVICES 100
MODEL  SHM
LDBAL  N

*MACHINES
DEFAULT:
  APPDIR="d:\tuxedoserver"
  TUXCONFIG="d:\tuxedoserver\tuxconfig"
  TUXDIR="c:\tuxedo\tuxedo8.0"
    MAXWSCLIENTS=50
    MAXACCESSERS=400

#Example:
#  APPDIR="/home/me/simpapp"
#  TUXCONFIG="/home/me/simpapp/tuxconfig"
#  TUXDIR="/usr/tuxedo"

KONGDL LMID=simple     #KONGDL 为计算机名称，要大写，根据自己的计算机名称修改即可

#Example:
#beatux  LMID=simple

*GROUPS
GROUP1
 LMID=simple GRPNO=1 OPENINFO=NONE

*SERVERS
DEFAULT:
  CLOPT="-A"

simpserv SRVGRP=GROUP1 SRVID=1

WSL SRVGRP=GROUP1 SRVID=5 CLOPT="-A -t -- -n //192.168.0.102:6565 -m 2 -M 5 -x 10"

*SERVICES
TOUPPER

 

　　3: 编译ubbsimple文件 

　　　　进入dos控制台，选择d:\tuxedoserver路径为当前目录，运行“tmloadcf -y ubbsimple”命令编译ubbsimple文件，成功之后会在d:\tuxedoserver目录下生成二进制的

        TUXCONFIG文件。

　　4: 编译服务端程序

　　　　在dos控制台中运行“buildserver -o simpserv -f simpserv.c -s TOUPPER -v”，命令编译服务端程序，源代码为simpserv.c文件，编译成功之后会在d:\tuxedoserver

　　目录下生成simpserv.exe文件。

　　5: 编译客户端程序

　　　　在dos控制台中运行“buildclient -o simpcl -f simpcl.c  -v -w”，命令编译服务端程序，源代码为simpserv.c文件，编译成功之后会在d:\tuxedoserver

　　目录下生成simpcl.exe文件。

　　6: 运行客户端程序simpcl.exe测试

　　在dos控制台中输入simpcl.exe hello　则返回HELLO，表示成功，如下图所示。

 

三：tuxedo编程

　　3.1 服务端程序

　　　SERVER端编程主要用C(或COBAL)语言编写一个个的SERVICE，如果需要进行数据库调用，则用数据库提供的嵌入S QL 语言的编程接口，如ORACLE 的PROC ，　　　INFORMIX的ESQL 等编写。一个SERVICE其实就时一个C 函数，但它的参数只能是一个TPSVCINFO结构体指针。该结构体在atmi.h中的定义：
　　struct tpsvcinfo {  
  　　　char  name[XATMI_SERVICE_NAME_LENGTH];/* service name invoked */ 
  　　　long    flags;     /* describes service attributes */
  　　　char    *data;     /* pointer to data */
  　　　long     len;       /* request data length */
  　　　int        cd;       /* reserved for future use */
  　　　long       appkey;     /* application authentication client key */
 　　　 CLIENTID  cltid;      /* client identi fier for originating client */ 
　　};
　　typedef struct tpsvcinfo TPSVCINFO;
 
　　TPSVRCINFO说明：
　　char   name[XATMI_SERVICE_NAME_LENGTH];  该SERVICE的名字
  　　long    flags;    CLIENT端在TPCALL ，TPACALL等的FLAGS中设置的值
 　　 char    *data;    指向CLIENT发送过来的缓冲区的首地址
  　　long     len;        data缓冲区的的长度
  　　int        cd;        当采用CONVERSATION 通讯方式时，对应的CD值 
　　 long       appkey;    当采用安全认证时，该CLIENT 所对应的KEY
          CLIENTID  cltid;     用于识别该CLIENT 的ID 
 
                在SERVER端的程序中可以调用TUXEDO 提供的ATMI 编程接口。这些函数主要在atmi.h中定义。一个SERVICE的处理结果可以用tpreturn返回到CLIENT  端或用t

　　pforward()转发给另一个SERVICE。
 
          Tpreturn（）函数：
           Void  tpreturn(int rval, int rcode, char *data,long len, long flags) 
           参数：
              rval：定义该SERVICE的返回值，可以是：
                         TPSUCCESS： CLIENT端的tpgetrply()  或  tpcall() 会返回一个非0 值。如果是用会话方式进行通讯，则会产生TPEV_SVCSUCC 事件。
                         TPFAIL：     CLIENT 端的tpgetrply()  或 tpcall() 会返回-1 。如果是用CONVERSATION 进行通讯，则会产生TPEV_SVCFAIL 事件。
                         TPEXIT：     和TPFAIL 一样，并且该SERVICE 所在的SERVER进程会自动退出。
                         Rcode：可以给它赋值，CLIENT 端可以用tpurcode() 取到该值。
                         Data：  返回给CLIENT端的缓冲区
                         Len：   Data 缓冲区的长度，只有该缓冲区类型为CARRAY时，才需要指定。
                         Flags：现在没用，设为0  

 
Tpsvrinit （）函数
Int tpsvrinit(int  argc, char  **argv) 
描述：在SERVER 启动时，它将自动调用函数：tpsvrinit(int argc, char *argv[])
如果该SERVER 所在的GROUP配置了连接数据库的接口，那么在默认情况下，该SERVICE将自动
调用TPOPEN（），建立与数据库的连接。
参数：int argc, char **argv 参数的含义与main() 函数的参数含义一样。
返回值：执行成功返回0，失败返回-1
 
tpsvrdone() 函数
void  tpsvrdone()
描述：tpdone()做一些清除工作，如断开与数据库的连接，从系统的BULLITON BOARD 中清除
与该SERVER对应的登记项。
参数：无
返回值：无
 
 
 
SERVER端程序的编译：
用buildserver编译SERVER 端程序，buildserver将调用C 编译器对SERVER端程序进行编译。
其格式如下：
buildserver [- o executable]... 
[ -v] \
[ -s service2, service3:func] \
[ -f source/object]...\
[ -l object] ...  \
[ -r resource manager]
 
说明：
- v  –  输出详细的编译信息
- o  executable – SERVER 的名字
- l  executable –  在连接TUXEDO的库之后，还要连接的库文件
- s  service  –  指定将要发布的SERVICE的名称
- f  source/object –  一个  .c  或  * .o 文件，它可以包含在该SERVER中的SERVICE调用到的函数
- r  resource manager –RM的名称

　　　simpserv.c程序如下。

#include
#include
#include  /* tuxedo　atmi接口头文件*/
#include  /* tuxedo　写日志信息，日至文件写入到服务端程序目录下，如ULOG.011813*/

#if defined(__STDC__) || defined(__cplusplus)
tpsvrinit(int argc, char *argv[])  //初始化，服务启动时有tuxedo 调用，可以打开数据库连接等
#else
tpsvrinit(argc, argv)
int argc;
char **argv;
#endif
{
 /* Some compilers warn if argc and argv aren't used. */
 argc = argc;
 argv = argv;

 /* userlog writes to the central TUXEDO message log */
 userlog("Welcome to the simple server");　　　//记录日志信息

 return(0);
}

#ifdef __cplusplus
extern "C"
#endif
void
#if defined(__STDC__) || defined(__cplusplus)
TOUPPER(TPSVCINFO *rqst)　　　//tuxedo 交易服务
#else
TOUPPER(rqst)
TPSVCINFO *rqst;
#endif
{

 int i;
 for(i = 0; i < rqst->len-1; i++)
  rqst->data[i] = toupper(rqst->data[i]);

 /* Return the transformed buffer to the requestor. */
 tpreturn(TPSUCCESS, 0, rqst->data, 0L, 0);
}

　

　　3.2 客户端程序

　　　　创建BEA Tuxedo的客户程序与在C和C++编程语言中创建其它应用程序一样，BEA Tuxedo提供了一个其于C语言的编程接口，即应用程序事务监控接口ATMI，这套接　　口很容易使用，以便用于开发客户程序和服务程序。除了C语言接口外，BEA Tuxedo还提供了COBOL接口。为了更好的了解客户端的所有任务以编写客户端应用，有必要　　重新认识客户端在C/S模式中扮演的角色。 首先，客户端是用户界面。意思是当用户在系统上用程序进行一次操作的整个过程就是一个客户端过程。前端过程是对客户端的　　另一个描述。客户端的首要任务就是获得执行操作应该得到的数据。一旦客户端得到了应有的信息，应该将数据按服务能够识别并适合传输的格式打包。 然后，向服务端　　发送请求并等待回应。收到回应数据后，将其按一定格式返回给终端用户。

　　客户端开发过程

　　　客户端程序的设计和实现可以被分成2部分考虑：用户处理过程和TUXEDO功能部分。下文的客户端程序只描述了TUXEDO功能部分。利用TUXEDO的ATMI API调用可以做到：

　　　——基本的TUXEDO调试技巧（tperrno,tpstrerror,userlog）

　　　——TUXEDO进程管理(tpinit,tpterm)

　　　——基本数据缓冲管理(tpalloc,tprealloc,tpfree)

　　　——基本通讯(tpcall,tpacall,tpgetrply)

　　　客户程序一般执行如下任务：

　　　1. 用tpchkauth()决定加入一个应用程序所需的安全级别。可能出现的响应包括：没有安全级别，应用程序口令，应用程序授权，访问控制列表，连接级加密，公钥加   

                密，审计。这些可以根据你的需求进行选择；在实际的应用中很多的软件开发商通常对这一步都不做处理。

            2,调用tpinit()来连接到一个BEA Tuxedo应用程序，所需的安全信息作为tpinit()的参数传给了应用程序；

         3.执行服务请求,调用tpcall

         4.调用tpterm()来断开和BEA Tuxedo应用程序的连接

    调试和错误处理

                    当调用ATMI出错时，返回值为-1，全程变量tperrno被设值，该变量提供系统定义的出错原因。函数tpstrerror()以此变量为参数，返回错误的字符说明信息。 完整的

           错误号和文本错误信息存在于文件$TUXDIR/include/atmi.h。函数userlog()重定向输出文件为ULOG.mmddyy。使用方法同printf()。该函数每次输出都写硬盘，这样在系

           统失败时也能保留调试信息。

       进程管理

          tuxedo 接到一个tpinit的请求后,就启动一个服务进程,接收到tpterm()后,就会中止该服务进程.在实际应用中,tpinit()和tpterm()必须成对出现,而且要相互对应.

      如果只在程序中调用了tpinit()而没有调用tpterm(),则tuxedo系统会认为该进程一直处于活动状态,这样的话可能会因为服务进程达到系统允许的上限而导致系统的崩

      溃.int tpinit(TPINIT *tpinfo)客户端通过调用tpinit()与应用连接，进行交互，有以下事件发生：调用安全接口检查客户端是否需要认证连接BB，使进一步的ATMI函数得到

            信息使BBL了解BB中已经存在请求建立客户端消息队列使服务可以发回返回信息，系统可以送出广播通知等.错误时返回-1，可能由以下原因引起：

            ²      TPEINVAL         参数错误

            ²       TPENOENT  BB无空间

            ²      TPEPERM         无连接权限

            ²      TPEPROTO 协议错误 –被服务调用

           int tpterm()

                   客户端调用tpterm()切断与应用的连接，结束了客户端的TUXEDO进程，该过程发生以下事件：BB入口删除，使BBL知道客户端已经离开客户端离开BB，客户端的信

           号量被移除客户端消息队列被移除错误时返回-1，可能由以下原因引起：TPEPROTO协议错误 –被服务调用TPESYSTEM     /T系统下错误TPEOS              操作系统错 

    数据缓冲管理

          在Bea Tuxedo系统中的所有通信过程都是通过类型缓冲区来完成的，Bea Tuxedo系统提供了大量的类型缓冲区来供开发者使用。所有类型缓冲区都必须通过Bea

            Tuxedo的tpalloc(), tprealloc(), tpfree()这些ATMI来分配回收，它们都有特定的头部。

             以下是TUXEDO基本的数据缓冲类型：

             ²      STRING  以空值结尾的单域字符数据。

             ²      CARRAY 有长度定义的单域二进制数据，不进行编、解码。

             ²      VIEW       类C结构或COBOL记录的多域组织。

             ²      FML         无固定结构的自定义缓冲。

 

四：delphi 客户端程序

　　4.1: 准备

         1: 从c:\tuxedo\tuxedo8.1\bin 目录下拷贝libbuft.dll，libengine.dll，libfml.dll，libfml32.dll，libgpnet.dll，libtux.dll，libwsc.dll，wtuxws32.dll文件到要编写的delphi程序的

　　　运行目录下。

　　 2: 编写tuxedo动态链接库声明文件tuxedo32.pas，该文件如下。

unit Tuxedo32;

interface

{$DEFINE WS}

const
  {add by ming}
  TPMULTICONTEXTS = 32;
  {Flags for service routines}
  TPNOBLOCK  = $00000001;
  TPSIGRSTRT = $00000002;
  TPNOREPLY  = $00000004;
  TPNOTRAN   = $00000008;
  TPTRAN     = $00000010;
  TPNOTIME   = $00000020;
  TPABSOLUTE = $00000040;
  TPGETANY   = $00000080;
  TPNOCHANGE = $00000100;
  TPCONV     = $00000400;
  TPSENDONLY = $00000800;
  TPRECVONLY = $00001000;
  TPACK      = $00002000;

  {Flags for tpreturn()}
  TPFAIL    = $00000001;
  TPSUCCESS = $00000002;
  TPEXIT    = $08000000;

  {Flags for tpscmt()}
  TP_CMT_LOGGED   = $01;
  TP_CMT_COMPLETE = $02;

  {Flags to tpinit()}
  TPU_MASK       = $00000007;
  TPU_SIG        = $00000001;
  TPU_DIP        = $00000002;
  TPU_IGN        = $00000004;
  TPSA_FASTPATH  = $00000008;
  TPSA_PROTECTED = $00000010;

  {Flags to tpconvert()}
  TPTOSTRING   = $40000000;
  TPCONVCLTID  = $00000001;
  TPCONVTRANID = $00000002;
  TPCONVXID    = $00000004;
  TPCONVMAXSTR = 256;

  {Return values of tpchkauth()}
  TPNOAUTH  = 0;
  TPSYSAUTH = 1;
  TPAPPAUTH = 2;

  {Misc}
  MAXTIDENT = 30;

  {Errors}
  TPEABORT      = 1;
  TPEBADDESC    = 2;
  TPEBLOCK      = 3;
  TPEINVAL      = 4;
  TPELIMIT      = 5;
  TPENOENT      = 6;
  TPEOS         = 7;
  TPEPERM       = 8;
  TPEPROTO      = 9;
  TPESVCERR     = 10;
  TPESVCFAIL    = 11;
  TPESYSTEM     = 12;
  TPETIME       = 13;
  TPETRAN       = 14;
  TPGOTSIG      = 15;
  TPERMERR      = 16;
  TPEITYPE      = 17;
  TPEOTYPE      = 18;
  TPERELEASE    = 19;
  TPEHAZARD     = 20;
  TPEHEURISTIC  = 21;
  TPEEVENT      = 22;
  TPEMATCH      = 23;
  TPEDIAGNOSTIC = 24;
  TPEMIB        = 25;

  { conversations - events }
  TPEV_DISCONIMM = $0001;
  TPEV_SVCERR    = $0002;
  TPEV_SVCFAIL   = $0004;
  TPEV_SVCSUCC   = $0008;
  TPEV_SENDONLY  = $0020;

type
  PPChar     = ^Pchar;
  PShortInt  = ^ShortInt;
  PLongInt   = ^LongInt;
  PInteger   = ^Integer;
  PSingle    = ^Single;
  PExtended  = ^Extended;
  TClientid = record
    Clientdata: array[1..4] of LongInt;
  end;

  PTClientid = ^TClientid;

{add by kongdl for add fml declare}
{add by kongdl}

{XATMI}

type
  TTpsvcinfo = record
    Name: array[0..31] of Char;
    Flags: LongInt;
    Data: PChar;
    Len: LongInt;
    Cd: Integer;
    Appkey: LongInt;
    Cltid: TClientid;
  end;
  PTTpsvcinfo = ^TTpsvcinfo;

function  tpacall       ( Svc, Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
function  tpadvertise   ( Svcname: PChar; Tpsvcinfo: Pointer ): Integer; stdcall;
function  tpalloc       ( Maintype, Subtype: PChar; Size: LongInt ): Pointer; stdcall;
//function  tpcall        ( Svc, Idata: PChar; Ilen: LongInt; Odata: PPChar; Olen: PLongInt; Flags:LongInt ): Integer; stdcall;
Function tpcall ( SVCNAME: pChar;   IDATA: pChar;  ILEN: LongInt;
          var ODATA: pChar;  var OLEN :LongInt;   flags :LongInt ): Integer;
          stdcall;external  'wtuxws32.dll'
function  tpcancel      ( Cd: Integer ): Integer; stdcall;
function  tpconnect     ( Svc, Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
function  tpdiscon      ( Cd: Integer ): Integer; stdcall;
procedure tpfree        ( Ptr: PChar ); stdcall;
function  tpgetrply     ( Cd: PInteger; Data: PPChar; Len: PLongInt; Flags: LongInt ): Integer; stdcall;
function  tprealloc     ( Ptr: PChar; Size: LongInt ): PChar; stdcall;
function  tprecv        ( Cd: Integer; Data: PPChar; Len: PLongInt; Flags: LongInt; Revent: PLongInt ): Integer; stdcall;
procedure tpreturn      ( Rval: Integer; Rcode: LongInt; Data: PChar; Len, Flags: LongInt ); stdcall;
function  tpsend        ( Cd: Integer; Data: PChar; Len, Flags: LongInt; Revent: PLongInt ): Integer; stdcall;
procedure tpservice     ( Svcinfo: PTTpsvcinfo ); stdcall;
function  tptypes       ( Ptr, Maintype, Subtype: PChar ): LongInt; stdcall;
function  tpunadvertise ( Svcname: PChar ): Integer; stdcall;
//hz add
function tpgetctxt(context:PLongInt;flags:LongInt): Integer; stdcall;
function  tpsetctxt(context:LongInt;flags:LongInt): Integer; stdcall;
{ATMI}

type
  TTpinit = record
    Usrname: array[0..31] of Char;
    Cltname: array[0..31] of Char;
    Passwd:  array[0..31] of Char;
    Grpname: array[0..31] of Char;
    Flags: LongInt;
    Datalen: LongInt;
    Data: longInt;
  end;

  TTpqctl = record
    Flags: LongInt;
    Deq_time: LongInt;
    Priority: LongInt;
    Diagnostic: LongInt;
    Msgid: array[0..31] of Char;
    Corrid: array[0..31] of Char;
    Replyqueue: array[0..16] of Char;
    Failurequeue: array[0..16] of Char;
    Cltid: TClientid;
    Urcode: LongInt;
    Appkey: LongInt;
  end;

  TTpevctl = record
    Flags: LongInt;
    Name1: array[0..31] of Char;
    Name2: array[0..31] of Char;
    Qctl: TTpqctl;
  end;

  TTptranid = record
    Info: array[0..5] of LongInt;
  end;

  PTTpinit   = ^TTpinit;
  PTTpqctl   = ^TTpqctl;
  PTTpevctl  = ^TTpevctl;
  PTTptranid = ^TTptranid;
  Unsolhandler = procedure ( Data: PChar; Len, Flags: LongInt ); stdcall;

function  tpabort       ( Flags: LongInt ): Integer; stdcall;
function  tpbegin       ( Timeout, Flags: LongInt ): Integer; stdcall;
function  tpbroadcast   ( Lmid, Usrname, Cltname, Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
function  tpchkauth     : Integer; stdcall;
function  tpchkunsol    : Integer; stdcall;
function  tpcommit      ( Flags: LongInt ): Integer; stdcall;
function  tpdequeue     ( Qspace, Qname: PChar; Ctl: PTTpqctl; Data: PPChar; Len: PLongInt; Flags: LongInt ): Integer; stdcall;
function  tpenqueue     ( Qspace, Qname: PChar; Ctl: PTTpqctl; Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
procedure tpforward     ( Svc, Data: PChar; Len, Flags: LongInt ); stdcall;
function  tpgetlev      : Integer; stdcall;
function  tpgprio       : Integer; stdcall;
function  tpinit        ( Tpinfo: PTTpinit ): Integer; stdcall;
function  tpnotify      ( Clientid: PTClientid; Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
function  tppost        ( Eventname, Data: PChar; Len, Flags: LongInt ): Integer; stdcall;
function  tpresume      ( Tranid: PTTptranid; Flags: LongInt ): Integer; stdcall;
function  tpsetunsol    ( Disp: Unsolhandler ): Unsolhandler; stdcall;
function  tpsprio       ( Prio: Integer; Flags: LongInt ): Integer; stdcall;
function  tpstrerror    ( Err: Integer ): PChar; stdcall;
function  tpsubscribe   ( Eventexpr, Filter: PChar; Ctl: PTTpevctl; Flags: LongInt ): Integer; stdcall;
function  tpsuspend     ( Tranid: PTTptranid; Flags: LongInt ): Integer; stdcall;
procedure tpsvrdone     ; stdcall;
function  tpsvrinit     ( Argc: Integer; Argv: PPChar ): Integer; stdcall;
function  tpterm        : Integer; stdcall;
function  tpunsubscribe ( Subscription, Flags: LongInt ): Integer; stdcall;

{TX}

type
  Txid = record
    FormatID: LongInt;
    Gtrid_Length: LongInt;
    Bqual_length: LongInt;
    Data: array[0..127] of Char;
  end;
  TTxinfo = record
    XID: TXID;
    When_Return: LongInt;
    Tran_Control: LongInt;
    Tran_Timeout: LongInt;
    Tran_State: LongInt;
  end;
  COMMIT_RETURN       = LongInt;
  TRANSACTION_CONTROL = LongInt;
  TRANSACTION_TIMEOUT = LongInt;

function  tx_begin                   : Integer; stdcall;
function  tx_close                   : Integer; stdcall;
function  tx_commit                  : Integer; stdcall;
function  tx_info                    ( Info: Pointer ): Integer; stdcall;
function  tx_open                    : Integer; stdcall;
function  tx_rollback                : Integer; stdcall;
function  tx_set_commit_return       ( When_return: COMMIT_RETURN ): Integer; stdcall;
function  tx_set_transaction_control ( Control: TRANSACTION_CONTROL ): Integer; stdcall;
function  tx_set_transaction_timeout ( Timeout: TRANSACTION_TIMEOUT ): Integer; stdcall;

{FML}

type
  FLDIDD  = Word;
  FLDLEN = Word;
  FLDOCC = Integer;
  TFbfr = record
    Magic: Integer;
    Len: FLDLEN;
    Maxlen: FLDLEN;
    Nie: FLDLEN;
    Indxintvl: FLDLEN;
    Val: array[0..7] of Byte;
  end;
  TFldidArray = array[0..99] of FLDIDD;
  PFLDIDD = ^FLDIDD;
  PFLDLEN = ^FLDLEN;
  PFLDOCC = ^FLDOCC;
  PTFbfr = ^TFbfr;
  PFldidArray = ^TFldidArray;

function  Fadd ( Fbfr: PTFbfr; Fieldid: FLDIDD; Value: Pointer; Len: FLDLEN ): Integer; stdcall;
function  Falloc ( F: FLDOCC; V:FLDLEN ): PTFbfr; stdcall;
function  Fchg ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Value: Pointer; Len: FLDLEN ): Integer; stdcall;
function  Fcmp ( Fbfr1, Fbfr2: PTFbfr ): Integer; stdcall;
function  Fcpy ( Dest, Src: PTFbfr ): Integer; stdcall;
function  Fdel ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC ): Integer; stdcall;
function  Fdel32 ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC ): Integer; stdcall;
function  Fdelall ( Fbfr: PTFbfr; Fieldid: FLDIDD ): Integer; stdcall;
function  Fdelete ( Fbfr: PTFbfr; PFieldid: PFldidArray ): Integer; stdcall;
function  Ffind ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Len: PFLDLEN ): Pointer; stdcall;
function  Ffindlast ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: PFLDOCC; Len: PFLDLEN ): integer; stdcall;
function  Ffindocc ( Fbfr: PTFbfr; Fieldid: FLDIDD; Value: Pointer; Len: FLDLEN ): FLDOCC; stdcall;
function  Fget ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Value: Pointer; Maxlen: PFLDLEN ): Integer; stdcall;
function  Fgetalloc ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Extralen: PFLDLEN ): Pointer; stdcall;
function  Fgetlast ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: PFLDOCC; Value: Pointer; Maxlen: PFLDLEN ): Integer; stdcall;
function  Finit ( Fbfr: PTFbfr; Buflen: FLDLEN ): Integer; stdcall;
function  Fldid ( Name: PChar ): FLDIDD; stdcall;
function  Fldno ( Fieldid: FLDIDD ): Integer; stdcall;
function  Fldtype ( Fieldid: FLDIDD ): Integer; stdcall;
function  Fmkfldid ( Itype: Integer; Num: FLDIDD ): FLDIDD; stdcall;
function  Fmove ( Dest: PChar; Src: PTFbfr ): Integer; stdcall;
function  Fname ( Fieldid: FLDIDD ): PChar; stdcall;
function  Fneeded ( F: FLDOCC; V: FLDLEN ): LongInt; stdcall;
function  Ffree ( Fbfr: PTFbfr ): Integer; stdcall;
function  Fnext ( Fbfr: PTFbfr; Fieldid: PFLDIDD; Oc: PFLDOCC; Value: Pointer; Len: PFLDLEN ): Integer; stdcall;
function  Fnum ( Fbfr: PTFbfr ): FLDOCC; stdcall;
function  Foccur ( Fbfr: PTFbfr; Fieldid: FLDIDD ): FLDOCC; stdcall;
function  Fpres ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC ): Integer; stdcall;
function  Frealloc ( Fbfr: PTFbfr; Nf: FLDOCC; Nv: FLDLEN ): PTFbfr; stdcall;
function  Fsizeof ( Fbfr: PTFbfr ): LongInt; stdcall;
function  Ftype ( Fieldid: FLDIDD ): PChar; stdcall;
function  Funused ( Fbfr: PTFbfr ): LongInt; stdcall;
function  Fused ( Fbfr: PTFbfr ): LongInt; stdcall;
function  Fvall ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC ): LongInt; stdcall;
function  Fvals ( Fbfr: PTFbfr; FIeldid: FLDIDD; Oc: FLDOCC ): PChar; stdcall;
function  Fconcat ( Dest, Src: PTFbfr ): Integer; stdcall;
function  Fjoin ( Dest, Src: PTFbfr ): Integer; stdcall;
function  Fojoin ( Dest, Src: PTFbfr ): Integer; stdcall;
function  Fproj ( Fbfr: PTFbfr; Fieldid: PFldidArray ): Integer; stdcall;
function  Fprojcpy ( Dest, Src: PTFbfr; Fieldid: PFldidArray ): Integer; stdcall;
function  Fupdate ( Dest, Src: PTFbfr ): Integer; stdcall;
function  CFadd ( Fbfr: PTFbfr; Fieldid: FLDIDD; Value: PChar; Len: FLDLEN; Itype: Integer ): Integer; stdcall;
function  CFchg ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Value: PChar; Len: FLDLEN; Itype: Integer ): Integer; stdcall;
function  CFget ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Buf: PChar; Len: PFLDLEN; Itype: Integer ): Integer; stdcall;
function  CFgetalloc ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Itype: Integer; Extralen: PFLDLEN ): PChar; stdcall;
function  CFfind ( Fbfr: PTFbfr; Fieldid: FLDIDD; Oc: FLDOCC; Len: PFLDLEN; Itype: Integer ): PChar; stdcall;
function  CFfindocc ( Fbfr: PTFbfr; Fieldid: FLDIDD; Value: PChar; Len: FLDLEN; Itype: Integer ): Integer; stdcall;
function  Ftypcvt ( Tolen: PFLDLEN; Totype: Integer; Fromval: PChar; Fromtype: Integer; Fromlen: FLDLEN ): PChar; stdcall;
function  Fidxused ( Fbfr: PTFbfr ): Integer; stdcall;
function  Findex ( Fbfr: PTFbfr; Intvl: FLDOCC ): Integer; stdcall;
function  Frstrindex ( Fbfr: PTFbfr; Numidx: FLDOCC ): Integer; stdcall;
function  Funindex ( Fbfr: PTFbfr ): Integer; stdcall;
function  Fboolco ( Expression: PChar ): PChar; stdcall;
function  Fboolev ( Fbfr: PTFbfr; Tree: PChar ): Integer; stdcall;
function  Ffloatev ( Fbfr: PTFbfr; Tree: PChar ): Double; stdcall;
procedure Fidnm_unload; stdcall;
procedure Fnmid_unload; stdcall;
function  Fchksum ( Fbfr: PTFbfr ): LongInt; stdcall;
function  Fielded ( Fbfr: PTFbfr ): Integer; stdcall;
function  Fstrerror ( Err: Integer ): PChar; stdcall;

{Miscellaneous}

type
  TNl_catd = record
    Catd_set: PChar;
    Catd_msgs: PChar;
    Catd_data: PChar;
    Catd_set_nr: Integer;
    Catd_type: Char;
  end;
  Nl_item = Integer;
  PTNl_catd = ^TNl_catd;

function  catgets     ( Catd: PTNl_catd; Set_num, Msg_num: Integer; S: PChar ): PChar; stdcall;
function  catopen     ( Name: PChar; Oflag: Integer ): PTNl_catd; stdcall;
function  catclose    ( Catd: PTNl_catd ): Integer; stdcall;
function  gettperrno  : Integer; stdcall;
//add by kongdl
function gettpurcode: integer; stdcall
//add by kongdl
function  nl_langinfo ( Item: Nl_item ): PChar; stdcall;
function  tuxgetenv   ( Name: PChar ): PChar; stdcall;
function  tuxputenv   ( Envstring: PChar ): Integer; stdcall;
function  tuxreadenv  ( Envfile, Envlabel: PChar ): Integer; stdcall;
function  userlog     ( Format: PChar ): Integer; stdcall;
{$IFDEF WS}
function  bq          ( Cmd: PChar ): Integer; stdcall;
function  setlocale   ( Category: Integer; Locale: PChar ): PChar; stdcall;
{$ENDIF}

{Others}

type
  TTm = record
    Tm_sec:   Integer;
    Tm_min:   Integer;
    Tm_hour:  Integer;
    Tm_mday:  Integer;
    Tm_mon:   Integer;
    Tm_year:  Integer;
    Tm_wday:  Integer;
    Tm_yday:  Integer;
    Tm_isdst: Integer;
  end;
  PTTm = ^TTm;

function  gp_mktime  ( Time: PTTm ): LongInt; stdcall;

implementation

{XATMI}

function  tpacall       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpacall';
function  tpadvertise   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpadvertise';
function  tpalloc       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpalloc';
//function  tpcall        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpcall';
function  tpcancel      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpcancel';
function  tpconnect     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpconnect';
function  tpdiscon      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpdiscon';
procedure tpfree        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpfree';
function  tpgetrply     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpgetrply';
function  tprealloc     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tprealloc';
function  tprecv        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tprecv';
procedure tpreturn      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpreturn';
function  tpsend        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsend';
procedure tpservice     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpservice';
function  tptypes       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tptypes';
function  tpunadvertise ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpunadvertise';

function  tpgetctxt     ; stdcall ; external {$IFDEF WS} 'libtux.dll' {$ELSE} 'wtuxws32.dll' {$ENDIF} name 'tpgetctxt';
function  tpsetctxt     ; stdcall ; external {$IFDEF WS} 'libtux.dll' {$ELSE} 'wtuxws32.dll' {$ENDIF} name 'tpsetctxt';

{ATMI}

function  tpabort       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpabort';
function  tpbegin       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpbegin';
function  tpbroadcast   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpbroadcast';
function  tpchkauth     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpchkauth';
function  tpchkunsol    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpchkunsol';
function  tpcommit      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpcommit';
function  tpdequeue     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpdequeue';
function  tpenqueue     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpenqueue';
procedure tpforward     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpforward';
function  tpgetlev      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpgetlev';
function  tpgprio       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpgprio';
function  tpinit        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpinit';
function  tpnotify      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpnotify';
function  tppost        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tppost';
function  tpresume      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpresume';
function  tpsetunsol    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsetunsol';
function  tpsprio       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsprio';
function  tpstrerror    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpstrerror';
function  tpsubscribe   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsubscribe';
function  tpsuspend     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsuspend';
procedure tpsvrdone     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsvrdone';
function  tpsvrinit     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpsvrinit';
function  tpterm        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpterm';
function  tpunsubscribe ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tpunsubscribe';

{TX}

function  tx_begin                   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_begin';
function  tx_close                   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_close';
function  tx_commit                  ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_commit';
function  tx_info                    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_info';
function  tx_open                    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_open';
function  tx_rollback                ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_rollback';
function  tx_set_commit_return       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_set_commit_return';
function  tx_set_transaction_control ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_set_transaction_control';
function  tx_set_transaction_timeout ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'tx_set_transaction_timeout';

{FML}

function  Fadd         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fadd';
function  Falloc       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Falloc';
function  Fchg         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fchg';
function  Fcmp         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fcmp';
function  Fcpy         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fcpy';
function  Fdel32       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fdel32';
//function  Fdel         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fdel';
function Fdel; stdcall; external 'libfml.dll' name 'Fdel';
function  Fdelall      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fdelall';
function  Fdelete      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fdelete';
function  Ffind        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ffind';
function  Ffindlast    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ffindlast';
function  Ffindocc     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ffindocc';
function  Ffree        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ffree';
function  Fget         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fget';
function  Fgetalloc    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fgetalloc';
function  Fgetlast     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fgetlast';
function  Finit        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Finit';
function  Fldid        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fldid';
function  Fldno        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fldno';
function  Fldtype      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fldtype';
function  Fmkfldid     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fmkfldid';
function  Fmove        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fmove';
function  Fname        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fname';
function  Fneeded      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fneeded';
function  Fnext        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fnext';
function  Fnum         ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fnum';
function  Foccur       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Foccur';
function  Fpres        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fpres';
function  Frealloc     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Frealloc';
function  Fsizeof      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fsizeof';
function  Ftype        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ftype';
function  Funused      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Funused';
function  Fused        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fused';
function  Fvall        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fvall';
function  Fvals        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fvals';
function  Fconcat      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fconcat';
function  Fjoin        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fjoin';
function  Fojoin       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fojoin';
function  Fproj        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fproj';
function  Fprojcpy     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fprojcpy';
function  Fupdate      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fupdate';
function  CFadd        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFadd';
function  CFchg        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFchg';
function  CFget        ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFget';
function  CFgetalloc   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFgetalloc';
function  CFfind       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFfind';
function  CFfindocc    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'CFfindocc';
function  Ftypcvt      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ftypcvt';
function  Fidxused     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fidxused';
function  Findex       ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Findex';
function  Frstrindex   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Frstrindex';
function  Funindex     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Funindex';
function  Fboolco      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fboolco';
function  Fboolev      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fboolev';
function  Ffloatev     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Ffloatev';
procedure Fidnm_unload ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fidnm_unload';
procedure Fnmid_unload ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fnmid_unload';
function  Fchksum      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fchksum';
function  Fielded      ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fielded';
function  Fstrerror    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libfml.dll' {$ENDIF} name 'Fstrerror';

{Miscellaneous}

function  catgets     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'catgets';
function  catopen     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'catopen';
function  catclose    ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'catclose';
function  gettperrno  ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'gettperrno';
//add by kongdl
function gettpurcode; stdcall; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'gettpurcode';
//add by kongdl
function  nl_langinfo ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'nl_langinfo';
function  tuxgetenv   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'tuxgetenv';
function  tuxputenv   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'tuxputenv';
function  tuxreadenv  ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'tuxreadenv';
function  userlog     ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libtux.dll' {$ENDIF} name 'userlog';
{$IFDEF WS}
function  bq          ; stdcall ; external 'wtuxws32.dll' name 'bq';
function  setlocale   ; stdcall ; external 'wtuxws32.dll' name 'setlocale';
{$ENDIF}

{Others}

function  gp_mktime   ; stdcall ; external {$IFDEF WS} 'wtuxws32.dll' {$ELSE} 'libgp.dll' {$ENDIF} name 'gp_mktime';

end.

　　　

　　4.2 调用tuxedo服务代码（该代码包含调用调用TOUPPER服务，调用数据库访问服务(TEST)，调用VIEW缓冲区服务VIEWTEST, FML缓冲区操作）

 　　　unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Tuxedo32, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    Edit1: TEdit;
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Edit2: TEdit;
    TabSheet2: TTabSheet;
    Label3: TLabel;
    edtEmpNO: TEdit;
    Label4: TLabel;
    edtName: TEdit;
    Button2: TButton;
    TabSheet3: TTabSheet;
    Label5: TLabel;
    edtBID: TEdit;
    Label6: TLabel;
    edtBalance: TEdit;
    Label7: TLabel;
    edtERMSG: TEdit;
    Label8: TLabel;
    edtResult: TEdit;
    Button3: TButton;
    TabSheet4: TTabSheet;
    Label9: TLabel;
    edtFMLEmpNO: TEdit;
    Label10: TLabel;
    edtFMLEmpName: TEdit;
    Label11: TLabel;
    edtFMLEmpSale: TEdit;
    Button4: TButton;
    Button5: TButton;
    Button7: TButton;
    lvFMLEmp: TListView;
    Button6: TButton;
    procedure Button1Click(Sender: TObject);
    procedure edtEmpNOKeyPress(Sender: TObject; var Key: Char);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure edtBalanceKeyPress(Sender: TObject; var Key: Char);
    procedure Button4Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure lvFMLEmpSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
  private
    { Private declarations }
    FBufFML: Pointer;      //FML缓冲区
    procedure GetEmpFromBuffer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
type
  TAUD = packed record
    b_id: dword;
    balance: single;
    ermsg: array[0..79] of char;
  end;

  PAUD = ^TAUD;

  TEmp = class
  private
    Serial: integer;
    EMPNO: integer;
    EMPName: string;
    EMPSale: double;
  end;

const
  EMPNO = FLDIDD(9193);
  ENAME = FLDIDD(41962);
  SAL = FLDIDD(33771);

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var bConn: boolean;
    iRes, iRcvLen: longint;
    sSrc: string;
    TPTTpinit: PTTpinit;
    bufSend, bufRcv: PChar;
begin
  try
    Screen.Cursor := crSQLWait;
    bConn := false;
    TPTTpinit := nil;
    bufSend := nil;
    bufRcv := nil;
    TPTTpinit := PTTpinit(tpalloc('TPINIT', nil, sizeOf(PTTpinit)));
    //tuxputenv('WSNADDR=//192.168.90.150:6565');
    iRes := TPInit(nil);
    if (iRes = -1) then
    begin
      Application.MessageBox(PChar(Format('初始化失败: %d！', [gettperrno])), '系统提示');
      Exit;
    end
    else
      bConn := true;

    sSrc := edit1.Text;
    bufSend := PChar(PTTpinit(tpalloc('STRING', nil, Length(sSrc) + 1)));
    bufRcv := PChar(PTTpinit(tpalloc('STRING', nil, Length(sSrc) + 1)));

    StrCopy(bufSend, PChar(sSrc));

    iRes := tpcall(PChar('TOUPPER'), bufSend, longint(Length(sSrc) + 1), bufSend, iRcvLen, TPNOBLOCK);

    if (iRes = -1) then
    begin
      Application.MessageBox('调用TOUPPER失败！', '系统提示');
      Exit;
    end
    else
    begin
      Edit2.Text := bufSend;
    end;
  finally
    if Assigned(TPTTpinit) then
      tpfree(pchar(TPTTpinit));
    if Assigned(bufSend) then
      tpfree(bufSend);
    if Assigned(bufRcv) then
      tpfree(bufRcv);
    if bConn then
      tpterm();
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.edtEmpNOKeyPress(Sender: TObject; var Key: Char);
begin
  if ((Ord(Key) > Ord('9')) or (Ord(Key) < Ord('0'))) and (Ord(Key) <> 8) then
    Key := #0;
end;

procedure TForm1.Button2Click(Sender: TObject);
var bConn: boolean;
    sNO: string;
    iRes, iRcvLen, iSendLen, iCode: LongInt;
    bufSend, bufRcv: PChar;
begin
  try
    Screen.Cursor := crSQLWait;
    bConn := false;
    bufSend := nil;
    bufRcv := nil;

    //连接服务器
    try
      iRes := tpinit(nil);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('连接tuxedo服务器失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end
      else
        bConn := true;

      sNO := IntToStr(StrToIntDef(edtEmpNO.Text, -1));
      iSendLen := Length(sNO);

      bufSend := PChar(tpalloc('STRING', nil, iSendLen));
      if bufSend = nil then
      begin
        Application.MessageBox(PChar(Format('初始化缓冲区失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      bufRcv := PChar(tpalloc('STRING', nil, iSendLen));
      if bufRcv = nil then
      begin
        Application.MessageBox(PChar(Format('初始化缓冲区失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      StrCopy(bufSend, PChar(sNO));

      //调用TEST服务
      iRes := tpcall('TEST', bufSend, 0, bufRcv, iRcvLen, 0);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('调用TEST服务失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end
      else
      begin
        iCode := tuxedo32.gettpurcode;
        if iCode = 0 then
          edtName.Text := bufRcv
        else
        begin
          edtName.Text := '';
          if iCode = 1 then
            Application.MessageBox('未查找到数据！', '系统提示')
          else
            Application.MessageBox(PChar(Format('调用失败：%s', [trim(bufRcv)])), '系统提示');
        end;
      end;
    except
      on e: Exception do
      begin
        Application.MessageBox(PChar(Format('调用TEST服务出错：%s', [e.Message])), '系统提示');
      end;
    end;
  finally
    if Assigned(bufSend) then
      tpfree(bufSend);
    if Assigned(bufRcv) then
      tpfree(bufRcv);
    if bConn then
      tpterm();

    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var bConn: boolean;
    iRes, iRcvLen, iCode: LongInt;
    bufAud: PAUD;
    bufRcv: PChar;
begin
  try
    Screen.Cursor := crSQLWait;
    bufAud := nil;
    bufRcv := nil;
    bConn := false;

    try
      iRes := tpinit(nil);

      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('连接tuxedo服务器失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end
      else
        bConn := true;

      bufAud := PAUD(tpalloc('VIEW', 'aud', SizeOf(TAUD)));
      if bufAud = nil then
      begin
        Application.MessageBox(PChar(Format('初始化缓冲区失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      bufRcv := tpalloc('STRING', nil, 1000);
      if bufRcv = nil then
      begin
        Application.MessageBox(PChar(Format('初始化缓冲区失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      FillChar(bufAud^, SizeOf(TAUD), 0);
      bufAud^.b_id := StrToIntDef(edtBID.Text, 1);
      bufAud^.balance := StrToFloatDef(edtBALANCE.Text, 0);
      StrCopy(bufAud^.ermsg, PChar(edtERMSG.Text));

      iRes := tpcall('VIEWTEST', PChar(bufAUD), 0, bufRcv, iRcvLen, 0);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('调用VIEWTEST服务失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end
      else
      begin
        iCode := tuxedo32.gettpurcode;
        if iCode = 0 then
          edtResult.Text := bufRcv
        else
        begin
          edtName.Text := '';
          if iCode = 1 then
            Application.MessageBox('调用失败：分配缓冲区失败', '系统提示')
          else
            Application.MessageBox(PChar(Format('调用失败：%s', [trim(bufRcv)])), '系统提示');
        end;
      end;
    except
      on e: Exception do
      begin
        Application.MessageBox(PChar(Format('调用VIEWTEST服务出错：%s', [e.Message])), '系统提示');
      end;
    end;
  finally
    if Assigned(bufAud) then
      tpfree(PChar(bufAud));
    if Assigned(bufRcv) then
      tpfree(bufRcv);
    if bConn then
      tpterm();

    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.edtBalanceKeyPress(Sender: TObject; var Key: Char);
begin
  if ((Ord(Key) > Ord('9')) or (Ord(Key) < Ord('0'))) and (Ord(Key) <> 8) and (Ord(Key) <> Ord('.')) then
    Key := #0
  else
  begin
    if (Ord(Key) = Ord('.')) and (Pos('.', TEdit(Sender).Text) > 0) then
      Key := #0;
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
var iEmpNO, iRes: integer;
    dEmpSale: double;
    sEmpName: string;
begin
  try
    Screen.Cursor := crSQLWait;

    if not Assigned(FBufFML) then
    begin
      try
        FBufFML := tpalloc('FML', nil, 1024);

        if FBufFML = nil then
        begin
          Application.MessageBox(PChar(Format('分配FML缓冲区出错: %d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          Exit;
        end;
      except
        on e: Exception do
        begin
          Application.MessageBox(PChar(Format('分配FML缓冲区出错: %s', [e.Message])), '系统提示');
        end;
      end;
    end;

    if trim(edtFMLEmpNO.Text) = '' then
    begin
      Application.MessageBox('请输入员工编号！', '系统提示');
      edtFMLEmpNO.SetFocus;
      Exit;
    end
    else
      iEmpNO := StrToInt(edtFMLEmpNO.Text);

    if trim(edtFMLEmpName.Text) = '' then
    begin
      Application.MessageBox('请输入员工姓名!', '系统提示');
      edtFMLEmpName.SetFocus;
      Exit;
    end
    else
      sEmpName := trim(edtFMLEmpName.Text);

    if trim(edtFMLEmpSale.Text) = '' then
    begin
      Application.MessageBox('请输入薪水！', '系统提示');
      edtFMLEmpSale.SetFocus;
      Exit;
    end
    else
      dEmpSale := StrToFloat(edtFMLEmpSale.Text);

    try
      iRes := Fadd(FBufFML, EMPNO, @iEmpNO, 0);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('调用Fadd失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      iRes := Fadd(FBufFML, ENAME, PChar(sEmpName), 0);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('调用Fadd失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      iRes := Fadd(FBufFML, SAL, @dEmpSale, 0);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('调用Fadd失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      GetEmpFromBuffer;
      Application.MessageBox('添加员工信息成功！', '系统提示');
    except
      on e: Exception do
      begin
        Application.MessageBox(PChar(Format('添加员工信息出错: %s', [e.Message])), '系统提示');
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Assigned(FBufFML) then
    tpfree(FBufFML);
end;

procedure TForm1.GetEmpFromBuffer;
var iSerial, iMaxRow, iRes: integer;
    oEmp: TEmp;
    oItem: TListItem;
    sBuf: array[0..1024] of char;
begin
  try
    Screen.Cursor := crSQLWait;
    if not Assigned(FBufFML) then
    begin
      try
        FBufFML := tpalloc('FML', nil, 1024);

        if FBufFML = nil then
        begin
          Application.MessageBox(PChar(Format('分配FML缓冲区出错: %d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          Exit;
        end;
      except
        on e: Exception do
        begin
          Application.MessageBox(PChar(Format('分配FML缓冲区出错: %s', [e.Message])), '系统提示');
        end;
      end;
    end;

    try
      iRes := Ffindlast(FBufFML, EMPNO, @iMaxRow, nil);
      if Fnum(FBufFML) = 0 then
        Exit;
       
      lvFMLEmp.Items.Clear;

      for iSerial := 0 to iMaxRow do
      begin
        oEmp := TEmp.Create;
        oEmp.Serial := iSerial;

        iRes := FGet(FBufFML, EMPNO, iSerial, @oEmp.EMPNO, nil);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('获取FML EMPNO出错：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          Exit;
        end;

        FillChar(sBuf, Length(sBuf), 0);
        iRes := FGet(FBufFML, ENAME, iSerial, @sBuf[0], nil);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('获取FML EMPName出错：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          Exit;
        end
        else
          oEmp.EMPName := sBuf;

        iRes := FGet(FBufFML, SAL, iSerial, @oEmp.EMPSale, nil);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('获取FML EMPSale出错：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          Exit;
        end;

        oItem := lvFMLEmp.Items.Add;
        oItem.Data := oEmp;
        oItem.Caption := IntToStr(oEmp.Serial);
        oItem.SubItems.Add(IntToStr(oEmp.EMPNO));
        oItem.SubItems.Add(oEmp.EMPName);
        oItem.SubItems.Add(Format('%.2f', [oEmp.EMPSale]));
      end;
    except
      on e: Exception do
      begin
        Application.MessageBox(PChar(Format('获取FML缓冲区数据出错：%s', [e.Message])), '系统提示');
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.lvFMLEmpSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  edtFMLEmpNO.Text := IntToStr(TEmp(Item.Data).EMPNO);
  edtFMLEmpName.Text := TEmp(Item.Data).EMPName;
  edtFMLEmpSale.Text := FloatToStr(TEmp(Item.Data).EMPSale);
end;

procedure TForm1.Button5Click(Sender: TObject);
var iRes, iEmpNO: integer;
    dEmpSale: double;
    sEmpName: string;
    oEmp: TEmp;
begin
  try
    Screen.Cursor := crSQLWait;
   
    if lvFMLEmp.Selected <> nil then
    begin
      oEmp := TEmp(lvFMLEmp.Selected.Data);
      if trim(edtFMLEmpNO.Text) = '' then
      begin
        Application.MessageBox('请输入员工编号！', '系统提示');
        edtFMLEmpNO.SetFocus;
        Exit;
      end
      else
        iEmpNO := StrToInt(edtFMLEmpNO.Text);

      if trim(edtFMLEmpName.Text) = '' then
      begin
        Application.MessageBox('请输入员工姓名!', '系统提示');
        edtFMLEmpName.SetFocus;
        Exit;
      end
      else
        sEmpName := trim(edtFMLEmpName.Text);

      if trim(edtFMLEmpSale.Text) = '' then
      begin
        Application.MessageBox('请输入薪水！', '系统提示');
        edtFMLEmpSale.SetFocus;
        Exit;
      end
      else
        dEmpSale := StrToFloat(edtFMLEmpSale.Text);

      try
        iRes := Fchg(FBufFML, EMPNO, oEmp.Serial, @iEmpNO, 0);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('调用Fchg失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          lvFMLEmpSelectItem(lvFMLEmp, lvFMLEmp.Selected, true);
          Exit;
        end;

        iRes := Fchg(FBufFML, ENAME, oEmp.Serial, PChar(sEmpName), 0);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('调用Fchg失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          lvFMLEmpSelectItem(lvFMLEmp, lvFMLEmp.Selected, true);
          Exit;
        end;

        iRes := Fchg(FBufFML, SAL, oEmp.Serial, @dEmpSale, 0);
        if iRes = -1 then
        begin
          Application.MessageBox(PChar(Format('调用Fchg失败：%d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
          lvFMLEmpSelectItem(lvFMLEmp, lvFMLEmp.Selected, true);
          Exit;
        end;

        GetEmpFromBuffer;
        Application.MessageBox('修改数据成功！', '系统提示');
      except
        on e: Exception do
        begin
           Application.MessageBox(PChar(Format('修改数据失败：%s', [e.Message])), '系统提示');
        end;
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.Button6Click(Sender: TObject);
var iRes: integer;
    oEmp: TEmp;
begin
  try
    if lvFMLEmp.Selected <> nil then
    begin
      oEmp := TEmp(lvFMLEmp.Selected.Data);

      iRes := Fdel(FBufFML, EMPNO, oEmp.Serial);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('删除FML缓冲区EMPNO失败: %d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      iRes := Fdel(FBufFML, ENAME, oEmp.Serial);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('删除FML缓冲区ENAME失败: %d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      iRes := Fdel(FBufFML, SAL, oEmp.Serial);
      if iRes = -1 then
      begin
        Application.MessageBox(PChar(Format('删除FML缓冲区EMPSale失败: %d-%s', [gettperrno, tpstrerror(gettperrno)])), '系统提示');
        Exit;
      end;

      GetEmpFromBuffer;
      Application.MessageBox('删除数据成功！', '系统提示');
    end;
  except
    on e: Exception do
    begin
      Application.MessageBox(PChar(Format('删除数据出错：%s', [e.Message])), '系统提示');
    end;
  end;
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
  GetEmpFromBuffer;
end;

end.

　　　　

　　4.3 源代码下载

　　      源代码下载路径为：http://download.csdn.net/detail/kongguoqing791025/5015183