powered by simpleCommunicator - 2.0.51     © 2025 Programmizd 02
Форумы / Firebird, InterBase [игнор отключен] [закрыт для гостей] / Прошу помощи по UDF
14 сообщений из 14, страница 1 из 1
Прошу помощи по UDF
    #39906728
zeon11
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
1. Велосипеды не мои, прошу не пинать, но тем не менее, что есть - то есть.

Есть сторонняя информационная система, осмотры пациентов хранит весьма экзотически, а именно, HTML-документ осмотра "зажимает" GZIP-ом, кодирует BASE64 и полученную строку сохраняет в VARCHAR(32000).

Есть другая информационная система, в неё надо автоматом перекидывать эти осмотры, но только они хранят RTF в BLOB.
Обе системы на FireBird 2.58, диалект 1
Написал работающую UDF-ку:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
{DECLARE EXTERNAL FUNCTION DTOA1
    CSTRING(16384),
    CSTRING(16384)
RETURNS PARAMETER 2
ENTRY_POINT 'DToA1' MODULE_NAME 'DToA.dll'; }
procedure DToA1({var BlobIn: TBlob;} DocaStr: PChar; cString: PChar); cdecl; export;
var  DecompressS, DecodeS, fs: string; // bLen: integer;  buffer:PChar;
    InStream, OutStream: TStringStream; RE: TRichEdit; f:TForm;
const MAX_RESULT_LEN = 16384;    // на 32767 не работает, возвращает пустую строку
begin
 try
  cString[0] := #0;
//  with BlobIn do if (not Assigned(Handle)) or (TotalLength = 0) then  Exit;
//  bLen := BlobIn.TotalLength;

//  GetMem(buffer, bLen + 2);
//  buffer[bLen] := #0;
  try
//  FillBuffer(blob, buffer, bLen - 1);
  DecodeS:=DecodeBase64(DocaStr);
  InStream :=TStringStream.Create(DecodeS);
  OutStream:=TStringStream.Create(fs);
  F:=TForm.Create(nil);
  RE:=TRichEdit.Create(nil);
  RE.Parent:=F;
  RE.PlainText:=False;
  InStream.position := 0;
  DecompressStream(InStream,OutStream);
  DecompressS:=OutStream.DataString;
  HTMLtoRTF(DecompressS, RE);
 DecompressS := GetRTFText(RE);
  try
    if (Length(DecompressS) >= MAX_RESULT_LEN) then
     begin
      DecompressS := Copy(DecompressS, 1, MAX_RESULT_LEN - 1);
     end;
     StrPCopy(cString, DecompressS);
   finally
   end;
  finally
   InStream.Free;
   OutStream.Free;
   RE.Free;
   F.Free;
//   FreeMem(buffer);
  end;
 except end;
end;     { работает   }





Если немного изменить процедуру, так, чтобы на вход подавать BLOB, то процедура возвращает пустую строку

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
procedure DToA3(var BlobIn: TBlob;  cString: PChar); cdecl; export;
var  DecompressS, DecodeS, fs: string;  bLen: integer;  DocaStr: PChar;
    InStream, OutStream: TStringStream; RE: TRichEdit; f:TForm;
const MAX_RESULT_LEN = 16384;
begin
 try
  cString[0] := #0;
  with BlobIn do if (not Assigned(Handle)) or (TotalLength = 0) then  Exit;
  bLen := BlobIn.TotalLength;

  GetMem(DocaStr, bLen + 2);
  DocaStr[bLen] := #0;
  try
  FillBuffer(BlobIn, DocaStr, bLen - 1);
  DecodeS:=DecodeBase64(DocaStr);  //!!  Тут ещё работает, DecodeS правильная
  InStream :=TStringStream.Create(DecodeS);
  OutStream:=TStringStream.Create(fs);
  F:=TForm.Create(nil);
  RE:=TRichEdit.Create(nil);
  RE.Parent:=F;
  RE.PlainText:=False;
  InStream.position := 0;
  DecompressStream(InStream,OutStream);
  DecompressS:=OutStream.DataString;
  HTMLtoRTF(DecompressS, RE);
 DecompressS := GetRTFText(RE);
  try
    if (Length(DecompressS) >= MAX_RESULT_LEN) then
     begin
      DecompressS := Copy(DecompressS, 1, MAX_RESULT_LEN - 1);
     end;
     StrPCopy(cString, DecompressS);
   finally
   end;
  finally
   InStream.Free;
   OutStream.Free;
   RE.Free;
   F.Free;
   FreeMem(DocaStr);
  end;
 except end;
end;     { не работает   } 





Контрольная процедура, без извращений, тоже работает:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
procedure BlobToCString(var blob: TBlob; cString: PChar); cdecl; export; 
var buffer:PChar;  SResult: string;  bLen: integer;
const MAX_RESULT_LEN = 32767;
begin
 try
  cString[0] := #0;
  with blob do if (not Assigned(Handle)) or (TotalLength = 0) then Exit;
  bLen := blob.TotalLength;
  GetMem(buffer, bLen + 2);
  buffer[bLen] := #0;
  try
   FillBuffer(blob, buffer, bLen - 1);
   try
    SResult :=  buffer; 
    if (Length(SResult) >= MAX_RESULT_LEN) then SResult := Copy(SResult, 1, MAX_RESULT_LEN - 1);
    StrPCopy(cString, SResult);
   finally
   end;
  finally
   FreeMem(buffer)
  end;
 except end;
end;




Иными словами, извращения без BLOB работают, получаю RTF-документ, BLOB без извращений тоже работает, а вот извращения с BLOB уже не работают
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906734
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
zeon11
Код: pascal
1.
except end;     { работает }

1. Просто молча не работает - не значит, что работает.
2. Здесь делфи никто не знает.
3. Версию делфи тоже никто не знает.

"Пустая строка" может получиться из-за любой ошибки, которую необходимо искать с помощью отладки и логов.
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906735
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
zeon11
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
DecodeS:=DecodeBase64(DocaStr);
  InStream :=TStringStream.Create(DecodeS);
  OutStream:=TStringStream.Create(fs);
  F:=TForm.Create(nil);
  RE:=TRichEdit.Create(nil);
  RE.Parent:=F;
  RE.PlainText:=False;
  InStream.position := 0;
  DecompressStream(InStream,OutStream);
  DecompressS:=OutStream.DataString;
  HTMLtoRTF(DecompressS, RE);
 DecompressS := GetRTFText(RE);

Да, если такой код дать исполнять серверу, который будет его вызывать из удф, то сервер долго не проживет из-за утечек при исключениях в любом месте.
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906737
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Про создание TForm в UDF ничего говорить не буду
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906766
Фотография kdv
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
zeon11чтобы на вход подавать BLOB, то процедура возвращает пустую строку
блоб блобу рознь. Из udf blob работает только через определение, которое требует наличия ссылок на функции BlobGetSegment и BlobPutSegment, в ibase.h это typedef struct blobcallback.
Через остальное оно не работает. Т.е. работает, но "внутри сервера", куда udf доступа нет. Что там у вас за TBlob - хрен его знает, скорее всего совсем не то, что надо.

см. http://www.ibase.ru/files/download/blobsaveload.zip
Впрочем, оно тоже теоретически могло устареть, это надо сверять с ibase.h последних версий FB.
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906802
fraks
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
YuRock
Про создание TForm в UDF ничего говорить не буду


А что, так можно было??
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906804
zeon11
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
fraks
YuRock
Про создание TForm в UDF ничего говорить не буду


А что, так можно было??


Работает-же.
Мне самому это не нравится, но мне надо получить RTF-документ, который можно получить только из экземпляра TRichEdit, который в свою очередь без Parent не создаётся. Вот и создаю экземпляр TForm. Если знаете более простой способ - буду благодарен.
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906828
ёёёёё
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
zeon11
TRichEdit, который в свою очередь без Parent не создаётся

nil ?
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39906890
Мимопроходящий
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
UDF тут *совсем* не нужна.
Модератор: Завязывай с обсценной лексикой с поводом и без повода. Некрасиво.
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39908545
Василий 2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
В разделе Дельфей не так давно была тема с таким же вопросом про richedit, но, емнип, никакой простой альтернативы не присоветовали. Разве что платные невизуальные компоненты
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39908571
Dimitry Sibiryakov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Василий 2никакой простой альтернативы не присоветовали.

Это потому, что в том разделе сложным считается всё, что нельзя натыкать мышкой.
Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39908604
zeon11
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
kdv
zeon11чтобы на вход подавать BLOB, то процедура возвращает пустую строку

блоб блобу рознь. Из udf blob работает только через определение, которое требует наличия ссылок на функции BlobGetSegment и BlobPutSegment, в ibase.h это typedef struct blobcallback.
Через остальное оно не работает. Т.е. работает, но "внутри сервера", куда udf доступа нет. Что там у вас за TBlob - хрен его знает, скорее всего совсем не то, что надо.

см. http://www.ibase.ru/files/download/blobsaveload.zip
Впрочем, оно тоже теоретически могло устареть, это надо сверять с ibase.h последних версий FB.

Вся информация, что касается UDF и BLOB на этом сайте, (да и на многих других сайтах) в конце концов произрастает от статьи на IBASE.RU , так что TBlob был правильным. За ссылку в ответе спасибо, сделал на этом материале работающую процедуру:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
function FillBuffStr(var blob: TBlob): string;
var Buffer: PChar;
  EndOfBlob: WordBool;
  MaxBufSize: integer;
  GotLength: integer;
begin
  Result:='';
  try
    if (Assigned(Blob.Handle)) or (Blob.TotalLength > 0) then // don't do anything is blob = 0
      begin
        // add fmShare... option to fmCreate as needed
        MaxBufSize:=Blob.MaxSegLength;
        GetMem(Buffer, MaxBufSize + 1);
        try
          repeat
            GotLength := 0; { !?! }

            with BLOb do
              EndOfBLOb := GetSegment(Handle, Buffer, MaxBufSize, GotLength);
            if (GotLength > 0) then {?}
              Result:=Result+StrPas(Buffer);
          until EndOfBLOb = True;

        finally
          FreeMem(Buffer, MaxBufSize + 1);
        end;
      end;
  except
  end;
end;



однако выяснилось, что при размере BLOB приближающимся к 32к выход из цикла по условию until EndOfBLOb = True происходит, а весь BLOB до конца не вычитывается, остаётся "хвостик"

Коллега по работе предложил немного изменённую процедуру:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
procedure FillBuffStr(var blob: TBlob;var str:TStringStream);
var Buffer: PChar;
  EndOfBlob: WordBool;
  MaxBufSize: integer;
  GotLength,TL: integer;
begin
  //Result:='';
  TL:=0;
  try
    if (Assigned(Blob.Handle)) or (Blob.TotalLength > 0) then // don't do anything is blob = 0
      begin
        // add fmShare... option to fmCreate as needed
        MaxBufSize:=Blob.MaxSegLength;
        GetMem(Buffer, MaxBufSize + 1);
        try
          repeat
            GotLength := 0; { !?! }

            with BLOb do
              EndOfBLOb := GetSegment(Handle, Buffer, MaxBufSize, GotLength);
            //if (GotLength > 0) then {?}
              str.WriteBuffer(Buffer^, GotLength);
            //Result:=Result+StrPas(Buffer);
              TL:=TL+ GotLength;
          until (EndOfBLOb = True) and (TL>=BLOb.TotalLength);

        finally
          FreeMem(Buffer, MaxBufSize + 1);
        end;
      end;
  except
  end;
  str.Seek(0,soBeginning) ;
end;

...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39908651
ёёёёё
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
zeon11,

зачем вы так пишите
Код: sql
1.
EndOfBLOb = True

?
...
Рейтинг: 0 / 0
Прошу помощи по UDF
    #39908693
zeon11
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
ёёёёё
zeon11,

зачем вы так пишите
Код: sql
1.
EndOfBLOb = True

?


Потому-что гладиолус домкрат
...
Рейтинг: 0 / 0
14 сообщений из 14, страница 1 из 1
Форумы / Firebird, InterBase [игнор отключен] [закрыт для гостей] / Прошу помощи по UDF
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]