Сделано под 2000скуль(sp4, авторизация у меня смешанная) , так что не знаю как это дело будет фунциклировать под 2005. Реализовано через интерфейс ODS, который вроде как обещано, не будет поддерживаться вскоре ))
library Project1;
uses
StrUtils,
SysUtils,
Classes,
srv in 'srv.pas',
sqldb_h in 'sqldb_h.pas',
sqlfront_h in 'sqlfront_h.pas';
//Для совместимости
Function __GetXpVersion():Longint; cdecl;
begin
Result:= ODS_VERSION;
end;
procedure printUsage(srvproc: pSRV_PROC; errMassage:AnsiString=''); forward;
function msg_handler(dbproc:PDBPROCESS; msgno:DBINT; msgstate:INT; severity: INT;
const msgtext:LPSTR; const srvname:PAnsiChar = nil; const procname:PAnsiChar = nil;
line:DBUSMALLINT = 0):RETCODE; cdecl; forward;
const
MAX_BINDTOKEN=255;
XP_ERROR = SRV_MAXERROR+1;
{В этой функции коннектимся к экземпляру скуля и выгребаем
max значение нрек-а из заданной таблицы в качестве входного параметра функции
}
// GetNrecSomeTable
function GetNrecSomeTable(srvproc: pSRV_PROC): RETCODE; cdecl;
var
msgError:AnsiString;
bType: byte;
fNull: BOOL;
cbMaxLen, cbActualLen: ULONG;
TableNameLen:integer;
TableName, myKey, serverName:array[0..255] of char;
i:integer;
//для подключения к базе
loginrec:PLOGINREC;
bImpersonated:LongBool;
dbproc:PDBPROCESS;
//
szBindToken:array[0..MAX_BINDTOKEN] of char;
bufLength:integer;
bufQuery:AnsiString;
rc:RETCODE;
nCol, nCols:integer;
valBuffer, pHost, pServer:Pchar;
begin
//проверка правильности (в т.ч. порядка и типов) переданных параметров
Result:=0;
FillChar(TableName, sizeOf(TableName), 0);
if srv_rpcparams(srvproc) = 3 then // Check if input parameters are present...
begin
cbMaxLen:=sizeof(myKey);
srv_paraminfo(srvproc, 1, @bType, // Let's use 1st input parameter!
@cbMaxLen, @cbActualLen, // NOTE: We assume here what only 2 parameters
@TableName[0], @fNull); //of type String can be passed!!!
cbMaxLen:=sizeof(myKey);
FillChar(myKey, sizeof(myKey), 0);
srv_paraminfo(srvproc, 2, @bType,
@cbMaxLen, @cbActualLen,
@myKey[0], @fNull);
bufQuery:=DupeString(#0,8000);
cbMaxLen:=Length(bufQuery)-1;
srv_paraminfo(srvproc, 3, @bType,
@cbMaxLen, @cbActualLen,
pchar(bufQuery), @fNull);
end
else
begin
//НЕПРАВИЛЬНЫЕ параметры
Result:=1;
exit;
end;
srv_paramsetoutput(srvproc, 2, nil, 0, System.True);
//подключение ОБРАТНО к базе данных
// Get a loginrec and register our error and message handlers.
loginrec := dblogin();
if loginrec=nil then begin
bufQuery:='DBLOGIN - is failed';
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
bufQuery:='';
Result:=1;
exit;
end;
// dbprocerrhandle(loginrec, (DBERRHANDLE_PROC) err_handler);
// dbprocmsghandle(loginrec, msg_handler);
(* dbprocerrhandle(loginrec, nil);
dbprocmsghandle(loginrec, nil);
*)
// Check for integrated security.
if (StrComp(srv_pfield(srvproc, SRV_LSECURE, nil), 'TRUE') = 0) then
begin
// Client has accessed using some form of integrated security
// Impersonate client and set DBSETLSECURE flag
bImpersonated := (srv_impersonate_client(srvproc) <> 0);
DBSETLSECURE(loginrec);
end
else
begin
// Set the user name, password, and application name for the remote
DBSETLUSER( loginrec, srv_pfield(srvproc, SRV_USER, nil) );
DBSETLPWD( loginrec, srv_pfield(srvproc, SRV_PWD, nil) );
end;
DBSETLAPP (loginrec, 'Project2.GetNrecSomeTable');
srv_rpcdb(srvproc, nil);
(*
i:=0;
valBuffer:=srv_pfield(srvproc, SRV_SPID, @i);
valBuffer:=srv_pfield(srvproc, SRV_NETSPID, @i);
valBuffer:=srv_pfield(srvproc, SRV_TYPE, @i);
valBuffer:=srv_pfield(srvproc, SRV_STATUS, @i);
valBuffer:=srv_pfield(srvproc, SRV_RMTSERVER, @i);
valBuffer:=srv_pfield(srvproc, SRV_HOST, @i);
valBuffer:=srv_pfield(srvproc, SRV_USER, @i);
valBuffer:=srv_pfield(srvproc, SRV_PWD, @i);
valBuffer:=srv_pfield(srvproc, SRV_CPID, @i);
valBuffer:=srv_pfield(srvproc, SRV_APPLNAME, @i);
valBuffer:=srv_pfield(srvproc, SRV_TDS, @i);
valBuffer:=srv_pfield(srvproc, SRV_CLIB, @i);
valBuffer:=srv_pfield(srvproc, SRV_LIBVERS, @i);
valBuffer:=srv_pfield(srvproc, SRV_ROWSENT, @i);
valBuffer:=srv_pfield(srvproc, SRV_BCPFLAG, @i);
valBuffer:=srv_pfield(srvproc, SRV_NATLANG, @i);
valBuffer:=srv_pfield(srvproc, SRV_PIPEHANDLE, @i);
valBuffer:=srv_pfield(srvproc, SRV_NETWORK_MODULE, @i);
valBuffer:=srv_pfield(srvproc, SRV_NETWORK_VERSION, @i);
valBuffer:=srv_pfield(srvproc, SRV_NETWORK_CONNECTION, @i);
valBuffer:=srv_pfield(srvproc, SRV_LSECURE, @i);
valBuffer:=srv_pfield(srvproc, SRV_SAXP, @i);
valBuffer:=srv_pfield(srvproc, SRV_UNICODE_USER, @i);
valBuffer:=srv_pfield(srvproc, SRV_UNICODE_PWD, @i);
valBuffer:=srv_pfield(srvproc, SRV_SPROC_CODEPAGE, @i);
valBuffer:=srv_pfield(srvproc, SRV_MSGLCID, @i);
valBuffer:=srv_pfield(srvproc, SRV_INSTANCENAME, @i);
valBuffer:=srv_pfield(srvproc, SRV_HASHPWD, @i);
*)
valBuffer:=srv_pfield(srvproc, SRV_RMTSERVER, nil);
srv_paramsetoutput(srvproc, 3, valBuffer, StrLen(valBuffer), System.False);
// Since the servername parameter is set to NULL, the connection will be
// opened to the local DBMS.
dbproc := dbopen(loginrec, valBuffer);
if(dbproc=nil)then begin
StrCat(valBuffer, ' - invalid DBOPEN');
srv_paramsetoutput(srvproc, 3, valBuffer, StrLen(valBuffer), System.False);
srv_senddone (srvproc, SRV_DONE_MORE, 0, 0);
dbfreelogin(loginrec);
Result:=1;
exit;
end
// dbsetuserdata (dbproc, pointer(pSrvProc));
FillChar(szBindToken, sizeof(szBindToken), 0);
// for i:=0 to MAX_BINDTOKEN do szBindToken
:=#0;
bufQuery:='Select max(f$nrec) from '+StrPas(@TableName[0]);
// Bind to the clients connection for shared transaction space.
// srv_getbindtoken (srvproc, szBindToken);
// Execute the SELECT * FROM table.
dbcmd(dbproc, PAnsiChar(bufQuery));
rc := dbsqlexec(dbproc);
if rc=FAIL then begin
valBuffer:='DBSQLEXEC - is failed';
srv_paramsetoutput(srvproc, 3, valBuffer, StrLen(valBuffer), System.False);
srv_senddone (srvproc, SRV_DONE_MORE, 0, 0);
dbclose( dbproc );
dbfreelogin(loginrec);
Result:=1;
exit;
end;
bufQuery:='';
//получение результата запроса
//bufQuery:='нет данных';
//srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
Repeat
rc := dbresults (dbproc);
case rc of
FAIL:begin //какая-то ошибка, ХЗ
bufQuery:='dbresults - FAIL';
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
bufQuery:='';
Result:=1;
break;
end;
SUCCEED:begin
end;
NO_MORE_RESULTS:begin //возможно, неверное имя таблицы
bufQuery:='dbresults - NO_MORE_RESULTS';
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
bufQuery:='';
Result:=1;
break;
end;
NO_MORE_RPC_RESULTS:begin
bufQuery:='dbresults - NO_MORE_RPC_RESULTS';
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
bufQuery:='';
Result:=1;
break;
end;
end;
// How many data columns are in the row?
nCols := dbnumcols (dbproc);
nCol:=1;
bufQuery:=format('cols=%d coltype=%d collen=%d '
, [nCols, DBINT(dbcoltype(dbproc,nCol)), dbcollen(dbproc, nCol)]);
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.false);
if (SRV_TDS_BINARY = DBINT(dbcoltype(dbproc,nCol)))
and (8=dbcollen(dbproc, nCol)) then
begin
srv_paramsetoutput(srvproc, 2, nil, 0, System.True);
while (dbnextrow(dbproc) <> NO_MORE_ROWS) do begin
BufLength:=dbdatlen (dbproc, nCol);
valBuffer:=pointer(dbdata(dbproc, 1));
srv_paramsetoutput(srvproc, 2, valBuffer, BufLength, System.False);
valBuffer:=nil;
break;
end;
end else begin
bufQuery:='F$NREC - non BINARY( 8 )';
srv_paramsetoutput(srvproc, 3, pchar(bufQuery), Length(bufQuery), System.False);
end;
Until (0=0);
srv_senddone (srvproc, SRV_DONE_MORE, 0, 0);
// Close the connection to SQL Server.
dbclose( dbproc );
dbfreelogin(loginrec);
end;
(*int err_handler(dbproc, severity, dberr, oserr, dberrstr, oserrstr)
DBPROCESS *dbproc;
int severity;
int dberr;
int oserr;
char *dberrstr;
char *oserrstr;
{
SRV_PROC* srvproc = ( SRV_PROC* ) dbgetuserdata(dbproc);
if (srvproc == NULL)
return 0;
srv_sendmsg(srvproc, SRV_MSG_ERROR, (DBINT) GETTABLE_MSG,
(DBTINYINT)severity, (DBTINYINT)0, NULL, 0, 0, dberrstr,
SRV_NULLTERM);
if ((dbproc == NULL) || (DBDEAD(dbproc)))
return(INT_EXIT);
return(INT_CANCEL);
}
*)
function msg_handler;//(dbproc:PDBPROCESS; msgno:DBINT; msgstate:INT; severity: INT; const msgtext:LPSTR):RETCODE; cdecl;
var
srvproc:pSRV_PROC;
begin
Result:=0;
srvproc := pSRV_PROC(dbgetuserdata(dbproc));
if (srvproc = nil) then exit;
if (severity < 10) then begin
// If informational message....
srv_sendmsg(srvproc, SRV_MSG_INFO, msgno, DBTINYINT(severity),
DBTINYINT(msgstate), nil, 0, 0, msgtext, SRV_NULLTERM);
exit;
end;
// Trap login fail message
if (msgno = REMOTE_FAIL) then begin
// Send a message to the client that
// the remote connection failed.
srv_sendmsg(srvproc, SRV_MSG_ERROR, DBINT(msgno), DBTINYINT(severity),
DBTINYINT(msgstate), nil, 0, 0,
'Login to remote DBMS failed (dbopen).', SRV_NULLTERM);
exit;
end;
// Must be an error message....
srv_sendmsg(srvproc, SRV_MSG_ERROR, msgno, DBTINYINT(severity),
DBTINYINT(msgstate), nil, 0, 0, msgtext, SRV_NULLTERM);
end;
// send XP usage info to client
Procedure printUsage;
begin
// usage: exec xp_hello <@param1 output>
// Example:
// declare @txt varchar(33)
// exec xp_hello @txt OUTPUT
(* if(errMassage<>'')and(srv_rpcparams(srvproc)>=3)and(srv_paraminfo(srvproc, 3, @pbType, 8000, cbActualLen, ))then
begin
srv_paramsetoutput(srvproc, 3, msgError, Length(bufQuery), System.False);
end;
srv_sendmsg(pSrvProc, SRV_MSG_ERROR, XP_ERROR, SRV_INFO, 1,
NULL, 0, 0,
'Usage: exec @rc=GetNrecSomeTable <@TableName varchar(100)>, <@retMaxNrec binary( 8 ) OUTPUT>' +
'[, <@ErrorMessage varchar(8000) OUTPUT>]',
SRV_NULLTERM);
srv_senddone(pSrvProc, (SRV_DONE_ERROR | SRV_DONE_MORE), 0, 0);
*)
end;
exports
__GetXpVersion,
// ProjecT2,
GetNrecSomeTable;
begin
end.
И еще отдавать в качестве параметра приходиться в виде dbname.dbo.имя таблицы. Так и не удалось победить пока шоб он все время автоматом выгребал нужное значение из конкретной таблицы БД, из которой собственно дерагается функция (огребаешь в этом случае почему то по поводу 'DBSQLEXEC - is failed' ):
declare @max#F$NREC binary( 8 ), @table_name varchar(200), @retCode int, @rc int, @msg varchar(256)
select @table_name = 'test.dbo.t$katorg'
exec @rc = master..GetNrecSomeTable @table_name, @max#F$NREC OUTPUT, @msg OUTPUT
select @rc, @table_name, @max#F$NREC, @msg