Пример на Lazarus

[dv]

Пример серверного плагина для Lazarus.
Компилировать следует в 32-битной версии Lazarus. (В 64-х битной компилируется, но сервер CommFort этот плагин не увидит).
В USES добавлены модули INTERFACES и DIALOGS. Они нужны только для процедуры SHOWMESSAGE.
C ними DLL становится тяжелее на 1,5 Мб.


https://ru.wikipedia.org/wiki/Lazarus - Описание Lazarus.
http://www.lazarus-ide.org/ - Официальный сайт.

[SV]

Пример серверного плагина для Lazarus.
Компилировать следует в 32-битной версии Lazarus. (В 64-х битной компилируется, но сервер CommFort этот плагин не увидит).
В USES добавлены модули INTERFACES и DIALOGS. Они нужны только для процедуры SHOWMESSAGE.
C ними DLL становится тяжелее на 1,5 Мб.


https://ru.wikipedia.org/wiki/Lazarus - Описание Lazarus.
http://www.lazarus-ide.org/ - Официальный сайт.

На лазарь перешёл?

[dv]

Дурная голова покоя не дает..
В качестве эксперимента - попробовал.

[Djagernaut]

Не знаю как насчет дурной головы, а вот польза очевидна!
Уважаемые знатоки кода прошу помощи, разместил объявление на плагин но что-то не берется никто, решил попробовать абы что абы как, взял за основу это решение:
Столкнулся с проблемой что не могу поймать текст события, может кто подскажет что не так делаю?

Код: Выделить всё

unit main;

{$MODE Delphi}
{$codepage utf8}

interface

uses
  Windows,
  SysUtils;

type
  TCommFortProcess = procedure(dwPluginID: DWORD; dID: DWORD; bOutBuffer: PAnsiChar; dwOutBufferSize: DWORD); stdcall;
  TCommFortGetData = function(dwID: DWORD; bInBuffer: PAnsiChar; dwInBufferSize: DWORD; bOutBuffer: PAnsiChar; dwOutBufferSize: DWORD): DWORD; stdcall;

function PluginStart(dwThisPluginID: DWORD; func1: TCommFortProcess; func2: TCommFortGetData): Integer; stdcall;
procedure PluginStop(); stdcall;
procedure PluginShowOptions(); stdcall;
procedure PluginShowAbout(); stdcall;
procedure PluginProcess(dwID: DWORD; bInBuffer: PAnsiChar; dwInBufferSize: DWORD); stdcall;
function PluginGetData(dwID: DWORD; bInBuffer: PAnsiChar; dwInBufferSize: DWORD; bOutBuffer: PAnsiChar; dwOutBufferSize: DWORD): DWORD; stdcall;
function PluginPremoderation(dwID: DWORD; wText: PWideChar; var dwTextLength: DWORD): Integer; stdcall;

function fReadInteger(bInBuffer: PAnsiChar; var iOffset: Integer): Integer;
function fReadText(bInBuffer: PAnsiChar; var iOffset: Integer): WideString;
procedure fWriteInteger(var bOutBuffer: PAnsiChar; var iOffset: Integer; iValue: Integer);
procedure fWriteText(bOutBuffer: PansiChar; var iOffset: Integer; uValue: WideString);

procedure LogTextToFile(const Msg: string);

implementation

var
  dwPluginID: DWORD;
  CommFortProcess: TCommFortProcess;
  CommFortGetData: TCommFortGetData;

procedure LogTextToFile(const Msg: string);
const
  CRLF = #13#10;
var
  LogFileName: array[0..MAX_PATH] of Char;
  hFile: THandle;
  BytesWritten: DWORD;
  AnsiMsg: AnsiString;
begin
  BytesWritten := 0;

  GetModuleFileName(HInstance, LogFileName, MAX_PATH);
  StrPCopy(LogFileName, ExtractFilePath(LogFileName) + 'CommFortCleanerPluginLog.txt');

  hFile := CreateFile(LogFileName, GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

  if hFile <> INVALID_HANDLE_VALUE then
  begin
    SetFilePointer(hFile, 0, nil, FILE_END);
    AnsiMsg := DateTimeToStr(Now) + ': ' + Msg + CRLF;
    WriteFile(hFile, AnsiMsg[1], Length(AnsiMsg), BytesWritten, nil);
    CloseHandle(hFile);
  end;
end;

function fReadInteger(bInBuffer: PAnsiChar; var iOffset: Integer): Integer;
begin
  Result := 0;
  CopyMemory(@Result, bInBuffer + iOffset, SizeOf(Integer));
  Inc(iOffset, SizeOf(Integer));
end;

function fReadText(bInBuffer: PAnsiChar; var iOffset: Integer): WideString;
var
  iLength: Integer;
begin
  Result := '';
  iLength := fReadInteger(bInBuffer, iOffset);
  SetLength(Result, iLength);

  if iLength > 0 then
    CopyMemory(@Result[1], bInBuffer + iOffset, iLength * SizeOf(WideChar));
  Inc(iOffset, iLength * SizeOf(WideChar));
end;

procedure fWriteInteger(var bOutBuffer: PAnsiChar; var iOffset: Integer; iValue: Integer);
begin
  CopyMemory(bOutBuffer + iOffset, @iValue, SizeOf(Integer));
  Inc(iOffset, SizeOf(Integer));
end;

procedure fWriteText(bOutBuffer: PAnsiChar; var iOffset: Integer; uValue: WideString);
var
  iLength: Integer;
begin
  iLength := Length(uValue);
  fWriteInteger(bOutBuffer, iOffset, iLength);

  if iLength > 0 then
    CopyMemory(bOutBuffer + iOffset, @uValue[1], iLength * SizeOf(WideChar));
  Inc(iOffset, iLength * SizeOf(WideChar));
end;

function PluginStart(dwThisPluginID: DWORD; func1: TCommFortProcess; func2: TCommFortGetData): Integer;
begin
  dwPluginID := dwThisPluginID;
  CommFortProcess := func1;
  CommFortGetData := func2;

  LogTextToFile('PluginStart: Plugin CommFort Cleaner initialized. ID: ' + IntToStr(dwPluginID));

  Result := Integer(TRUE);
end;

procedure PluginStop();
begin
  LogTextToFile('PluginStop: Plugin CommFort Cleaner stopped.');
end;

procedure PluginProcess(dwID: DWORD; bInBuffer: PAnsiChar; dwInBufferSize: DWORD);
var
  MessageText: WideString;
  ReadOffset: Integer;
begin
  LogTextToFile('PROCESS_MSG: dwID=' + IntToStr(dwID) + ', Size=' + IntToStr(dwInBufferSize));

  if dwInBufferSize > 0 then
  begin
    ReadOffset := 0;
    try
      MessageText := fReadText(bInBuffer, ReadOffset);
      LogTextToFile('PROCESS_MSG: Text="' + MessageText + '"');
    except
      MessageText := 'Error reading text or not a text message.';
      LogTextToFile('PROCESS_MSG: Error reading text.');
    end;
  end
  else
  begin
    MessageText := '';
  end;
end;

function PluginGetData(dwID: DWORD; bInBuffer: PAnsiChar; dwInBufferSize: DWORD; bOutBuffer: PAnsiChar; dwOutBufferSize: DWORD): DWORD;
var
  iWriteOffset, iSize: Integer;
  uName: WideString;
begin
  Result := 0;

  iWriteOffset := 0;

  if (dwID = 2800) then // (0 = клиент/сервер)
  begin
    if (dwOutBufferSize = 0) then
      Result := SizeOf(Integer)
    else
    begin
      fWriteInteger(bOutBuffer, iWriteOffset, 0); 
      Result := SizeOf(Integer);
    end;
  end
  else if (dwID = 2810) then
  begin
    uName := 'CommFort Cleaner Plugin';
    iSize := Length(uName) * SizeOf(WideChar) + SizeOf(Integer);

    if (dwOutBufferSize = 0) then
      Result := iSize
    else
    begin
      fWriteText(bOutBuffer, iWriteOffset, uName);
      Result := iSize;
    end;
  end;
end;

function PluginPremoderation(dwID: DWORD; wText: PWideChar; var dwTextLength: DWORD): Integer;
var
  CurrentText: WideString;
begin
  Result := Integer(FALSE);

  if not Assigned(wText) or (dwTextLength = 0) then
  begin
    LogTextToFile('PREMOD_MSG: wText is nil or dwTextLength is 0. dwID: ' + IntToStr(dwID));
    dwTextLength := 0;
    Exit;
  end;

  SetLength(CurrentText, dwTextLength);
  CopyMemory(@CurrentText[1], wText, dwTextLength * SizeOf(WideChar));

  LogTextToFile('PREMOD_MSG: dwID=' + IntToStr(dwID) + ', Length=' + IntToStr(dwTextLength) + ', Text="' + CurrentText + '"');

  // Логика ОТКЛЮЧЕНА
end;

procedure PluginShowOptions();
begin
  // LogTextToFile('PluginShowOptions called.');
end;

procedure PluginShowAbout();
begin
  // LogTextToFile('PluginShowAbout called.');
end;

exports
  PluginStart,
  PluginStop,
  PluginProcess,
  PluginGetData,
  PluginShowOptions,
  PluginShowAbout,
  PluginPremoderation;

begin
end.

Возможно я в принципе не правильным путем иду и стоит пытаться писать серверный плагин у меня используется линковка серверов и постоянно вылезают сообщения о разрыве связи когда линк к главному серверу не доступен. Уж очень достали эти:

0:36 Произошло отключение от сервера
0:36 Связь восстановлена
0:36 Произошло отключение от сервера
0:36 Связь восстановлена

Суть идеи проста оставить все служебные сообщения в событиях а общие каналы только с тем текстом который туда был отправлен пользователями, ну и стартовой шапкой канала, километры этих служебных сообщений в канале в истории за неделю набирается самое смешное в приватных каналах такой ерунды нет.

[Djagernaut]

После долгих мучений пришёл к выводу что данное сообщение генерируется клиентом, по каким принципам и логике?! А фиг его знает, почему в приватных каналах сообщений нет а в тех что грузятся с сервера есть не понятно, похоже избавится от него можно толко поменяв систему связи…