Martin Schreiber mse00000@... [firebird-support] a écrit :

> On Thursday 15 September 2016 11:09:43 Dimitry Sibiryakov sd@...
> [firebird-support] wrote:
>> 15.09.2016 11:14, Martin Schreiber mse00000@... [firebird-support]
>> wrote:
>>> What if one wants to use
>>> IAttachment.execute() where no IStatement is available?
>>
>> (S)he must provide IMetadata built with builder.
>
> I am implementing a Firebird 3 connection component for MSEide+MSEgui (a Free
> Pascal toolkit) so I don't know the returned data of the statements in the
> first place.
> In case of input params I implemented an own IMessageMetadata derivate which
> uses the type information of TParam in order to setup the metadata. In case
> of "returning" the data type is unknown without parsing the SQL statement.
> It seems I always need to prepare the statement first?
>
> Martin

below, a bit dirty but functional code in codetyphon, reading the
buffer is RS

unit UserData;
{$mode delphi}
{$H+}

interface

uses
Classes, SysUtils, lNet, Firebird, DateUtils,
Tzutil, stdctrls, fgl,
TgzIo,
TzDeflate,
TzCompres,
FBRecordU;

type
FBSockException = class(Exception);
TByteArray = array of byte;
TListoutBuffer = array of TByteArray;
buf_byte_ptr = ^buf_byte;
buf_byte = array[0..4095] of byte;
buf_AnsiChar = array of AnsiChar;
buf_AnsiCharptr = ^buf_AnsiChar;

InMessage = record
n: SmallInt;
nNull: WordBool;
end;
OutMessage = record
relationId: SmallInt;
relationIdNull: WordBool;
relationName: array[0..93] of AnsiChar;
relationNameNull: WordBool;
end;

TDataEvent = procedure (Data: AnsiString) of object;

TServerObjectWorkerThread = class;
TThrdExeProc = procedure of object;
TServerObjectWorkerThread = class(TThread)
protected
FName : String;
FStarted : Boolean;
FThrdExeProc : TThrdExeProc;
public
procedure Execute; override;
property Name : String read FName
write FName;
property Started : Boolean read FStarted
write FStarted;
property ThrdExeProc : TThrdExeProc read FThrdExeProc
write FThrdExeProc;
end;


TUserData = class
private
_userdata : string;
_asocket : TLSocket;
_fmemo : TMemo;
st : IStatus;
master : IMaster ;
util : IUtil;
dpb : IXpbBuilder;
prov : IProvider;
att : IAttachment;
tra : ITransaction;
stmt: IStatement;
rs: IResultSet;
inMetadata, outMetadata: IMessageMetadata;
inBuffer: InMessage;
outBuffer: array of byte;
outBufferptr: ^TByteArray;
strm: TMemoryStream;
procedure writeuserdata(fdata:String);
procedure PrintError(s : IStatus; fmessage:string);
private
procedure sendfirstbuffer;
procedure senddata(fdata:ansistring);
procedure sendSize(fint:uint);
Procedure SendCompressedString(str: ansistring);
Procedure SendCompressedBytes(str: tBytesStream);
Procedure SendRecord(str : ansiString);
Function CompressToString(str: ansistring):ansistring;
function concatbyte(a, b: array of byte):TByteArray;
public
constructor create(fsocket:TLSocket;amemo:tmemo);
destructor destroy; override;
property userdata : string read _userdata write writeuserdata;
const
RAW_WBITS = 15;

end;

implementation


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * *}
procedure TServerObjectWorkerThread.Execute;

begin

end;


constructor TUserData.create(fsocket:TLSocket; amemo:TMemo);
begin
_asocket := fsocket;
_asocket.SetState(ssNoDelay,true);
_fmemo := amemo;
_userdata := '';
strm := TMemoryStream.create;
end;
destructor TUserData.destroy;
begin
if att<> nil then
att.detach(st);
att := nil;
if dpb <> nil then
dpb.dispose;
dpb := nil;
if prov <> nil then
prov.release;
prov := nil;
if st <> nil then begin
st.dispose();
end;
st := nil;
if util<> nil then
util := nil;
if master<>nil then
master := nil;
_userdata:='';
if inMetadata <> nil then
inMetadata := nil;
if outMetadata <> nil then
outMetadata := nil;
_asocket.UserData:=nil;
if strm<> nil then
freeandnil(strm);
inherited destroy;
end;

procedure TUserdata.PrintError(s : IStatus; fmessage:string);
var
maxMessage : Integer;
outMessage : PAnsiChar;
begin
maxMessage := 256;
outMessage := StrAlloc(maxMessage);
util.formatStatus(outMessage, maxMessage, s);
_fmemo.Append(concat(outMessage,#13#10,fmessage));
StrDispose(outMessage);
end;


procedure TUserdata.writeuserdata(fdata:string);
var starttime, stoptime: TDateTime;
begin
if trim(fdata) = 's' then begin
starttime := now;
sendfirstbuffer;
stoptime:=now;
_fmemo.append('Excecute total time in '+
inttostr(DateUtils.MilliSecondsBetween(starttime, stoptime)));
end else begin
_userdata:= _userdata+fdata;
if ((fdata = #13#10) or(fdata = ';')) then
_asocket.sendmessage(_userdata+#13#10);

end;
end;

procedure TUserData.sendfirstbuffer;
procedure ByteArrayToStrEx2( a : array of Byte; offset:
cardinal;flength:cardinal;ftype:cardinal;fscale:cardinal;CharSet:Cardinal;out
newoutbuffer:TBytes ) ;
(*******************
* SQL definitions *
*******************)
(*
SQL_TEXT = 452; // Array of char
SQL_VARYING = 448;
SQL_SHORT = 500;
SQL_LONG = 496;
SQL_FLOAT = 482;
SQL_DOUBLE = 480;
SQL_D_FLOAT = 530;
SQL_TIMESTAMP = 510;
SQL_BLOB = 520;
SQL_ARRAY = 540;
SQL_QUAD = 550;
SQL_TYPE_TIME = 560;
SQL_TYPE_DATE = 570;
SQL_INT64 = 580;
SQL_BOOLEAN = 32764;
SQL_NULL = 32766;
SQL_DATE = SQL_TIMESTAMP;
*)

//J : longint;
K : Byte;
i : integer;
C : cardinal;
WordByte:array[0..1]of byte;
StringLen : word;


begin
K := 0;
if flength = 100 then
K := 0;
case ftype of
500,
496,
580,
482: begin
setlength(newoutbuffer,flength);
move(a[offset],newoutbuffer[0],flength);
end;
448: begin
move(a[offset],WordByte[0],2);
StringLen:=word(WordByte);
C :=StringLen;
StringLen := StringLen+4;
setlength(newoutbuffer,StringLen);
if C>0 then begin
move(a[offset+2],newoutbuffer[4],C);
for i:=StringLen-1 downto 3 do
if newoutbuffer[i]<>32 then
break;
if i<StringLen-1 then
setlength(newoutbuffer,i);
end;
move(cardinal(C),newoutbuffer[0],4);
end;
452: begin
setlength(newoutbuffer,flength+4);
move(cardinal(flength) ,newoutbuffer[0],4);
move(a[offset],newoutbuffer[4],flength);
end;
520,
540,
550: begin
setlength(newoutbuffer,flength+4);
move(cardinal(flength) ,newoutbuffer[0],4);
move(a[offset],newoutbuffer[4],flength);
end
else begin
//For I:=offset to flength-1 do
// s :=s+ Chr(a[I]) ; // for a[I] equals 149 this
will get me "?" instead of "•" S:=S+tmp;
//s:=replacestr(s,#0,' ');
end;
end;

end;

procedure ByteArrayToStrEx3( a : array of Byte; R: FBRecord; out
newoutbuffer:TBytes ) ;
(*******************
* SQL definitions *
*******************)
(*
SQL_TEXT = 452; // Array of char
SQL_VARYING = 448;
SQL_SHORT = 500;
SQL_LONG = 496;
SQL_FLOAT = 482;
SQL_DOUBLE = 480;
SQL_D_FLOAT = 530;
SQL_TIMESTAMP = 510;
SQL_BLOB = 520;
SQL_ARRAY = 540;
SQL_QUAD = 550;
SQL_TYPE_TIME = 560;
SQL_TYPE_DATE = 570;
SQL_INT64 = 580;
SQL_BOOLEAN = 32764;
SQL_NULL = 32766;
SQL_DATE = SQL_TIMESTAMP;
*)

Var
//J : longint;
//K : Byte;
//i : integer;
C : cardinal;
WordByte:array[0..1]of byte;
// CardinalByte:array[0..3]of byte;
StringLen : word;
offset:
cardinal;flength:cardinal;ftype:cardinal;fscale:cardinal;CharSet:Cardinal;
begin
//K := 0;

offset:=R.offset;flength:=R.LengthByte;ftype:=R.typeField;fscale:=R.scale;CharSet:=R.CharSet;
case ftype of
500,
496,
580,
482,
560,
570,
510,
530,
32764: begin
setlength(newoutbuffer,flength);
move(a[offset],newoutbuffer[0],flength);
end;
32766: begin
//not;-)
end;
448: begin
move(a[offset],WordByte[0],2);
StringLen:=word(WordByte);
C :=StringLen;
StringLen := StringLen+4;
setlength(newoutbuffer,StringLen);
move(a[offset+2],newoutbuffer[4],C);
move(cardinal(C),newoutbuffer[0],4);
end;
452: begin
setlength(newoutbuffer,flength);
move(a[offset],newoutbuffer[0],flength);
end;
520,
540,
550: begin
setlength(newoutbuffer,flength+4);
move(cardinal(flength) ,newoutbuffer[0],4);
move(a[offset],newoutbuffer[4],flength);
end
else begin
//For I:=offset to flength-1 do
// s :=s+ Chr(a[I]) ; // for a[I] equals 149 this
will get me "?" instead of "•" S:=S+tmp;
//s:=replacestr(s,#0,' ');
end;
end;
end;
var
ty_count, i, ii, ty_lengthbuffer, outmetadatalength: integer;
s : ansistring;
gh : TBytesStream;
newoutbuffer : TBytes;
ListOfRecord : TFPGList<FBRecord>;
fFBRecord : FBRecord;
starttime, stoptime: TDateTime;
transactime,fbrecordtime,writebytetime,sendtime:integer;
begin
try
if master = nil then
master := fb_get_master_interface;
if util = nil then
util := master.getUtilInterface;
if st = nil then
st := master.getStatus;
if prov = nil then
prov := master.getDispatcher;
if dpb = nil then begin
dpb := util.getXpbBuilder(st, IXpbBuilder.DPB, nil, 0);
dpb.insertInt(st, isc_dpb_page_size, 4 * 1024);
dpb.insertString(st,isc_dpb_set_db_charset,'ISO8859_1');
dpb.insertInt(st,isc_dpb_set_db_sql_dialect,3);
dpb.insertString(st, isc_dpb_user_name, 'sysdba');
dpb.insertString(st, isc_dpb_password, 'ZebigPassword');
end;
if att = nil then
att := prov.attachDatabase(st,
'tetrasys.fi/7845:g:\fbdatas3_rc2\NORPANET_TETRASYS_09.FI.FB3',
dpb.getBufferLength(st), dpb.getBuffer(st));
tra := att.startTransaction(st, 0, nil);
starttime := now;
stmt := att.prepare(st, tra, 0,
'select a.* from rm_customers a rows 100;',
3, IStatement.PREPARE_PREFETCH_METADATA);
stoptime := now;
transactime := DateUtils.MilliSecondsBetween(starttime,
stoptime);
inMetadata := stmt.getInputMetadata(st);
outMetadata := stmt.getOutputMetadata(st);

inBuffer.nNull := false;
inBuffer.n := 15;
rs := stmt.openCursor(st, tra, inMetadata, 0{%H-}, outMetadata,
IStatement.CURSOR_TYPE_SCROLLABLE);
outmetadatalength := outMetadata.getMessageLength(st);
setlength(outBuffer,outmetadatalength+1);
outBufferptr := @outBuffer[0];
s:='';
ii := 0;
ty_lengthbuffer := length(outBuffer);
ty_count := outMetadata.getCount(st);
gh:=tBytesStream.create;
ListOfRecord := TFPGList<FBRecord>.create;
starttime := now;
for i:=0 to ty_count-1 do begin

fFBRecord := FBRecord.create(
outMetadata.getField(st,i),

outMetadata.getRelation(st,i),
outMetadata.getOwner(st,i),
outMetadata.getAlias(st,i),
outMetadata.getType(st,i),

outMetadata.isNullable(st,i),

outMetadata.getSubType(st,i),
outMetadata.getLength(st,i),
outMetadata.getScale(st,i),

outMetadata.getCharSet(st,i),

outMetadata.getOffset(st,i));
ListOfRecord.Add(fFBRecord);
if i<>0 then
gh.WriteByte(30);
gh.WriteBuffer(ListOfRecord[i].Byte[0],274);
end;
gh.WriteByte(23);
stoptime := now;
fbrecordtime := DateUtils.MilliSecondsBetween(starttime,
stoptime);
starttime := now;
//read buffer
while (rs.fetchNext(st, outBufferptr) = Integer(0))do begin
for i:=0 to ty_count-1 do begin
ByteArrayToStrex3(outBuffer,ListOfRecord[i],newoutbuffer);
ii := length(newoutbuffer);
if ii <> 0 then begin
gh.WriteBuffer(newoutbuffer[0],ii);
end else gh.WriteDWord(cardinal(65535));
setLength(newoutbuffer,0);
end;
if rs.isEof(st) then
gh.WriteByte(23)
else
gh.WriteByte(31);
end;

stoptime := now;
writebytetime := DateUtils.MilliSecondsBetween(starttime,
stoptime);
starttime := now;
for i:=0 to ty_count-1 do begin
ListOfRecord[i].Free;
end;
freeandnil(ListOfRecord);
SendCompressedBytes(gh);
gh.Clear;
gh.Free;
stoptime := now;
sendtime := DateUtils.MilliSecondsBetween(starttime, stoptime);
_fmemo.append('Transac time :
'+inttostr(transactime)+#13#10+'FBRecords time :
'+inttostr(fbrecordtime)+#13#10+'Write byte time :
'+inttostr(writebytetime)+#13#10+inttostr(sendtime));
except
on e: FbException do PrintError(e.getStatus,e.Message);
end;

rs.release();
inMetadata.release();
outMetadata.release();
stmt.free(st);
tra.commit(st);
tra := nil;

end;
procedure TUserData.senddata(fdata: ansistring);
begin
_asocket.sendmessage(fdata);
end;

procedure TUserData.sendSize(fint: uint);
begin
_asocket.send(fint,4);
sysutils.sleep(1);
end;

Procedure TUserData.SendRecord(str: ansistring);
var
outbyte : integer;
begin
outbyte := length(str);
sendSize(outbyte);
_asocket.sendmessage(str);
_fmemo.append('Send records out '+inttostr(outbyte)+' byte''s');
end;

Procedure TUserData.SendCompressedString(str: ansistring);
var
bufferOut:AnsiString;
outbyte : integer;
len : uLong;
i, ii: integer;
zfile : gzFile;
p : pchar;
err : int;
begin
p:=pchar(str);
len := strlen(p)+1;
zfile := gzopen(strm,'w9f',false);
outbyte := gzputs(zfile, p);
ii:= gzflush(zfile,3);
gzerror(zfile, err);
gzclose(zfile);
if err >=0 then begin
SetString(bufferOut, PChar(strm.Memory), strm.Size div
SizeOf(Char));
i := length(bufferOut);
sendSize(i);
_asocket.sendmessage(bufferOut);
_fmemo.append('Send Compress in '+inttostr(len)+' byte''s, out
'+inttostr(i)+' byte''s');
end else begin
_asocket.send(err, sizeof(integer));
strm.Clear;
_fmemo.append(concat('Error compress n° : ',inttostr(err),#13#10));
exit;
end;
strm.Clear;
end;


Procedure TUserData.SendCompressedbytes(str: tBytesStream);
var
bufferOut:AnsiString;
outbyte : integer;
len : uLong;
i, ii: integer;
zfile : gzFile;
p : pchar;
err : int;
begin
err := 0;
p:=pchar(str.bytes);
len := str.size;
zfile := gzopen(strm,'w9f',false);
outbyte := gzwrite(zfile,p,len);
ii:= gzflush(zfile,3);
gzerror(zfile, err);
gzclose(zfile);
if err >=0 then begin
SetString(bufferOut, PChar(strm.Memory), strm.Size div
SizeOf(Char));
i := length(bufferOut);
sendSize(i);
ii:=_asocket.send(PChar(bufferOut)^,i);
if ii<>i then _fmemo.append('Send error size buff :'+inttostr(ii)+'
- '+inttostr(i)) else
_fmemo.append('Send Compress in '+inttostr(len)+' byte''s, out
'+inttostr(i)+' byte''s');
end else begin
_asocket.send(err, sizeof(integer));
strm.Clear;
_fmemo.append(concat('Error compress n° : ',inttostr(err),#13#10));
exit;
end;
strm.Clear;

end;

Function TUserData.CompressToString(str: ansistring):ansistring;
var
bufferOut:AnsiString;
outbyte : integer;
len : uLong;
ii: integer;
zfile : gzFile;
err : int;
fbyte:tbytesstream;
gh:pBytef;
begin


fbyte:=tbytesstream.create;
fbyte.writeansistring(str);
len :=fbyte.size+12;
outbyte:= compress(gh, len, fbyte.bytes, fbyte.size);
SetString(bufferOut, pchar(gh), sizeof(gh) div SizeOf(Char));
result := bufferOut;
_fmemo.append(inttostr(strlen(pchar(str)))+' - '+inttostr(sizeof(gh)
div SizeOf(Char)));
exit;

zfile := gzopen(strm,'w9f',false);

outbyte := gzwrite(zfile,voidp(str),len);
ii:= gzflush(zfile,3);
ii:= gzflush(zfile,4);
gzerror(zfile, err);
gzclose(zfile);
if err >=0 then begin
SetString(bufferOut, PChar(strm.Memory), strm.Size div
SizeOf(Char));
result := bufferOut;
end else begin
result := 'erreur : '+inttostr(err);
strm.Clear;
_fmemo.append(concat('Error compress n° : ',inttostr(err),#13#10));
end;

strm.Clear;
strm.free;
end;

function TUserData.concatbyte(a, b: array of byte): TByteArray;
var ia, ib: Longint;
begin
ia := length(a);
ib := length(b);
if ia>0 then
SetLength(result, ia +ib)
else
SetLength(result,ib);
if ia>0 then
move(a,result[ia],ia);
move(b,result[ia],ib);
end;

end.

--
Norbert Saint Georges
http://tetrasys.fi