Martin Schreiber mse00...@gmail.com [firebird-support] a écrit :
> On Thursday 15 September 2016 11:09:43 Dimitry Sibiryakov s...@ibphoenix.com 
> [firebird-support] wrote:
>> 15.09.2016 11:14, Martin Schreiber mse00...@gmail.com [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

  • [firebird-suppor... Martin Schreiber mse00...@gmail.com [firebird-support]
    • Re: [firebi... Dimitry Sibiryakov s...@ibphoenix.com [firebird-support]
      • Re: [fi... Martin Schreiber mse00...@gmail.com [firebird-support]
        • Re:... Dimitry Sibiryakov s...@ibphoenix.com [firebird-support]
          • ... Martin Schreiber mse00...@gmail.com [firebird-support]
            • ... Dimitry Sibiryakov s...@ibphoenix.com [firebird-support]
              • ... Martin Schreiber mse00...@gmail.com [firebird-support]
                • ... Norbert Saint Georges n...@tetrasys.eu [firebird-support]
                • ... Martin Schreiber mse00...@gmail.com [firebird-support]

Reply via email to