PHP DM Gate v0.9 » Проблема с WebModule1 <span class="vd">[D7, WinXP]</span>

raslmc © (18.08.09 19:37) [0]

Добрый день.
Пытаюсь создать модуль для Apache.
Есть вот такой код:

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
s: string;
n: integer;
Stream: TMemoryStream;
begin

Response.ContentType := 'application/octet-stream';
Stream := TMemoryStream.Create;

s := 'Hello WorldHello WorldHello WorldHello WorldHello ';
Stream.Write(s[1], length(s));
Stream.Position := 0;

try
for n := 1 to 1024 do
begin
Response.SendStream(Stream);
sleep(20);
end;
finally
Stream.Free;
end;
end;

После подключения клиента срабатывает событие
WebModule1WebActionItem1Action и начинается отправка файла клиенту. Для примера отправляю ерунду.
Проблема в том, если клиент отсоединится во время отправки,
сама отправка все равно рабоает. События OnDisconnect не нашел. Скажите можно ли как то узнатьчто клиент отключился чтобы прервать отправку? К примеру:

...
for n := 1 to 1024 do
begin
if client.disconnected then break;
Response.SendStream(Stream);
sleep(20);
end;
...

Спасибо

<Цитата>
Сергей М. © (18.08.09 22:03) [1]

> отправка все равно рабоает

На основание чего сделано сие умозаключение ?

<Цитата>
raslmc © (18.08.09 22:24) [2]

На основании этого:

procedure Log(str: string);
var f: TFileStream;
begin
str := str + #13#10;
f := TFileStream.Create('c:\log.txt', fmOpenWrite);
f.Position := f.Size;
f.Write(str[1], length(str));
f.Free;
end;

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
s: string;
n: integer;
Stream: TMemoryStream;
begin

Log('Connected '+ DateTimeToStr(Now));

Response.ContentType := 'application/octet-stream';
Stream := TMemoryStream.Create;

s := 'Hello WorldHello WorldHello WorldHello WorldHello ';
Stream.Write(s[1], length(s));
Stream.Position := 0;

try
for n := 1 to 1024 do
begin
Response.SendStream(Stream);
sleep(20);
end;
finally
Stream.Free;
Log('Disconnected '+ DateTimeToStr(Now));
end;
end;

Объясню.
Когда клиент подключается в лог файл записывается
Log('Connected '+ DateTimeToStr(Now));

И начинается отправка.
В конце отправки
Log('Disconnected '+ DateTimeToStr(Now));

По идее, если клиент оборвет связь во время приема информации от сервера, сервер должен завершить
Response.SendStream(Stream);

ошибкой, либо просто закрыть поток.
Но после обрыва соединения поток все равно работает до конца.
В данном примере отправка занимает 20 секунд. И все 20 секунд поток висит и отправляет. Что при отправки больших файлов и большой нагруженности не есть хорошо.

<Цитата>
Сергей М. © (19.08.09 08:42) [3]

Вникни в это:

function TApacheRequest.WriteClient(var Buffer; Count: Integer): Integer;
begin
Result := 0;
if Count > 0 then
Result := ap_rwrite(Buffer, Count, FRequest_rec) //<-- вот здесь выполняется собственно отправка
end;

procedure TApacheTwoResponse.SendStream(AStream: TStream);
var
Buffer: array[0..8191] of Byte;
BytesToSend: Integer;
begin
while AStream.Position < AStream.Size do
begin
BytesToSend := AStream.Read(Buffer, SizeOf(Buffer));
FHTTPRequest.WriteClient(Buffer, BytesToSend); //<-- к сожалению, результат вызова метода игнорируется
end;
end;

<Цитата>
raslmc © (19.08.09 09:08) [4]

Уважаемый Сергей.
Благодарю за Ваш пинок. Помогло.
Вот решение:

В ApacheTwoHTTP нужно добавить

TApacheTwoResponse = class(TWebResponse)
private
...
public
...
function SendStream2(AStream: TStream): Integer;
...
end;
.......

function TApacheTwoResponse.SendStream2(AStream: TStream): Integer;
var
Buffer: array[0..8191] of Byte;
BytesToSend: Integer;
begin
while AStream.Position < AStream.Size do
begin
BytesToSend := AStream.Read(Buffer, SizeOf(Buffer));
result := FHTTPRequest.WriteClient(Buffer, BytesToSend);
end;
end;

А вот определяем, что клиент отключился и завершаем цикл:

Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
s: string;
n: integer;
Stream: TMemoryStream;
begin

Log('Connected '+ DateTimeToStr(Now));

Response.ContentType := 'application/octet-stream';
Stream := TMemoryStream.Create;

s := 'Hello WorldHello WorldHello WorldHello WorldHello ';
Stream.Write(s[1], length(s));
Stream.Position := 0;

try
for n := 1 to 1024 do
begin
if TApacheTwoResponse(Response).SendStream2(Stream) < 0 then break;
sleep(20);
end;
finally
Stream.Free;
Log('Disconnected '+ DateTimeToStr(Now));
end;
end;

P.S. файл ApacheTwoHTTP.pas должен находится в одной папке с проектом.
Спасибо.

<Цитата>
Сергей М. © (19.08.09 09:37) [5]

> нужно добавить

Если уж на то пошло, то можно было и не добавлять новый метод SendStream2, а просто подзаточить имеющийся процедурный SendStream, сделав его функциональным.

<Цитата>
Сергей М. © (19.08.09 09:47) [6]

Т.е.

TWebResponse = class(TObject)
..
function SendStream(AStream: TStream): Integer; virtual; abstract;
..
end;

TApacheTwoResponse = class(TWebResponse)
..
function SendStream(AStream: TStream): Integer; override;
..
end;

Тогда это избавит от необходимости явного приведения типа в строке

if TApacheTwoResponse(Response).SendStream2(Stream) < 0 then break;

Просто
if Response.SendStream(Stream) < 0 then break;

<Цитата>
raslmc © (19.08.09 10:42) [7]

Спасибо.
Правда пришлось еще несколько файлов из папки
Delphi7\Source\Internet скопировать в папку с программой.

<Цитата>