lazarus-ccr/applications/fpchess/ltelnetex.pas

unit ltelnetex;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  lTelnet, lnet,
  sorokinregexpr,
  Forms;

type
  TLTelnetDebugOutProc = procedure (AStr: string) of object;

  { TLTelnetClientEx }

  TLTelnetClientEx = class(TLTelnetClient)
  private
    FOnDebugOut: TLTelnetDebugOutProc;
    RegexObj: TRegExpr;
  public
    LastMsg: string;
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    function WaitFor(FirstMatch, SecondMatch: string; ATimeOut: Cardinal): Integer;
    property OnDebugOut: TLTelnetDebugOutProc read FOnDebugOut write FOnDebugOut;
  end;

implementation

{ TLTelnetClientEx }

constructor TLTelnetClientEx.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  RegexObj := TRegExpr.Create;
end;

destructor TLTelnetClientEx.Destroy;
begin
  RegexObj.Free;
  inherited Destroy;
end;

{ Returns a zero-based index to which regular expression was found
  or -1 if none was found
}
function TLTelnetClientEx.WaitFor(FirstMatch, SecondMatch: string;
  ATimeOut: Cardinal): Integer;
var
  lMsg: string;
  lRemaining: Integer;
begin
  lRemaining := ATimeOut;
  Result := -1;
  if (FirstMatch = '') and (SecondMatch = '') then Exit;

  repeat
    if GetMessage(lMsg) > 0 then
      if Assigned(OnDebugOut) then OnDebugOut(lMsg);

    LastMsg := lMsg;

    if FirstMatch <> '' then
    begin
      RegexObj.Expression := FirstMatch;
      if RegexObj.Exec(lMsg) then Exit(0);
    end;

    if SecondMatch <> '' then
    begin
      RegexObj.Expression := SecondMatch;
      if RegexObj.Exec(lMsg) then Exit(1);
    end;

    CallAction; // don't forget to make the clock tick :)
    if lRemaining > 0 then // Don't sleep if the routine was called with ATimeOut=0
    begin
      Application.ProcessMessages;
      Sleep(100);
    end;
    Dec(lRemaining, 100);
  until lRemaining <= 0;
end;

end.