unit U_ZaapSentinel2;

interface
uses
  Classes, Types;

type
  // http://www.ztree.com/html/zaap.htm
  TZaapPamphletHeader_2 = packed record
    case Boolean of
      True: (                           //  index
        Sequence: Word;                 //  00..01
        HWnd: Cardinal;                 //  02..05
        Handshake: AnsiChar;            //  06
        ScreenStatus: AnsiChar;         //  07
        Command: AnsiChar;              //  08
        CommandChar: AnsiChar;          //  09
        Page: AnsiChar;                 //  10
        BlockSize: Byte;                //  11      block-1
        Revision: Byte;                 //  12      block-2
        Stats: AnsiChar;                //  13      block-3
        Reserved1: array[4..8] of Byte; // 14..18   block-4..block-8
//        FullPath_CurrentPanel: string;
//        FullPath_OtherPanel: string;
//        EntryLine: string;
//        CheckSum: Word;
//        SequenceCheck: Word;
        );
      False: (
        Bytes: array[0..13] of Byte;
      );
  end;

type
  TZaapSentinelFile = class
  type
    THandshakeResponse = (hrOk, hrTag, hrUntag, hrOperationError, hrSyntaxError);
  private
    FStream: TFileStream;

    FHeader: TZaapPamphletHeader_2;
    FSequence: word;
    FWindowHandle: cardinal;
    FThisPath: string;
    FOtherPath: string;
    FEntryLine: string;
    FChecksum: word;
    FCheckSeq: word;

    FHasProblem: boolean;
    FProblem: string;

    procedure SetProblem(const Description: string);
    procedure ClearProblem;
    function GetFilename: string;
    procedure RotateChecksum(var CS: Word; const B: Byte); overload; inline;
    procedure RotateChecksum(var CS: Word; const B: array of Byte); overload;
  public
    constructor Create(const Filename: string);
    destructor  Destroy; override;

    function Refresh: boolean;
    function WaitForUpdate(const TimeoutMs: Cardinal; const PollIntervalMs: Cardinal = 100): boolean;

    procedure WriteResponse(const Response: THandshakeResponse; const Text: string);
    procedure Reset;

    property Filename: string                 read GetFilename;

    property HasProblem: boolean              read FHasProblem;
    property Problem: string                  read FProblem;

    property Pamphlet: TZaapPamphletHeader_2  read FHeader    write FHeader;
    property ThisPath: string                 read FThisPath;
    property OtherPath: string                read FOtherPath;
    property EntryLine: string                read FEntryLine;

    property Checksum: word                   read FChecksum;
    property CheckSeq: word                   read FCheckSeq;

  public
    class function FindAllSentinels: TStringDynArray;
  end {TZaapSentinelFile};

implementation

uses
  SysUtils, Windows, System.IOUtils;


function QueryFullProcessImageName( hProcess: THandle;
                                    dwFlags: DWORD;
                                    lpExeName: PChar;
                                    var nSize: DWORD): BOOL; stdcall; external
                                    kernel32 name 'QueryFullProcessImageName' +
                                    {$IFDEF UNICODE} 'W' {$ELSE} 'A' {$ENDIF};

{ ================================================================================================ }
{ TZaapSentinelFile }

{ ------------------------------------------------------------------------------------------------ }
constructor TZaapSentinelFile.Create(const Filename: string);
begin
  FSequence := High(FSequence);
  FWindowHandle := 0;
  FStream := TFileStream.Create(Filename, fmOpenReadWrite or fmShareDenyNone);
end {TZaapSentinelFile.Create};

{ ------------------------------------------------------------------------------------------------ }
destructor TZaapSentinelFile.Destroy;
begin
  FStream.Free;
  inherited;
end;

{ ------------------------------------------------------------------------------------------------ }
function TZaapSentinelFile.Refresh: boolean;
type
  TInField = (ifThisPath, ifOtherPath, ifEntryLine, ifTail);
var
  Buffer: array of Byte;
  MS: TMemoryStream;
  SS: TStringStream;
  B: Byte;
  InField: TInField;
  Checksum: Word;
begin
  ClearProblem;

  FStream.Position := 0;
  Result := FStream.Read(FHeader, SizeOf(FHeader)) = SizeOf(FHeader);
  if not Result then begin
    SetProblem('Sentinel file is smaller than pamphlet header size.');
    Exit;
  end;

  // Check if the pamphlet has changed since last time we read it
  if (FHeader.Sequence = FSequence) and (FHeader.HWnd = FWindowHandle) then begin
    Result := False;
    Exit;
  end else begin
    FWindowHandle := FHeader.HWnd;
    FSequence := FHeader.Sequence;
  end;

  Result := True;
  // Calculate checksum
  Checksum := 0;
  RotateChecksum(Checksum, FHeader.Bytes);

  // Skip the reserved block (minus the three already defined field bytes)
  SetLength(Buffer, FHeader.BlockSize - 3 - Length(FHeader.Reserved1));
  FStream.Read(Buffer[0], Length(Buffer));
  RotateChecksum(Checksum, Buffer);

  SS := TStringStream.Create('', TEncoding.UTF8);
  try
    MS := TMemoryStream.Create;
    try
      MS.CopyFrom(FStream, FStream.Size - FStream.Position);

      MS.Position := 0;
      InField := ifThisPath;
      while (MS.Position < MS.Size - 1) do begin
        MS.Read(B, SizeOf(B));
        RotateChecksum(Checksum, B);
        if InField < ifTail then begin
          if B > 0 then begin
            SS.Write(B, SizeOf(B));
          end else begin
            case InField of
              ifThisPath: begin
                FThisPath := SS.DataString;
                SS.Clear;
                InField := ifOtherPath;
              end;
              ifOtherPath: begin
                FOtherPath := SS.DataString;
                SS.Clear;
                InField := ifEntryLine;
              end;
              ifEntryLine: begin
                FEntryLine := SS.DataString;
                SS.Clear;
                InField := ifTail;
              end;
            end {case};
          end;
        end else begin // InField = ifTail
          // Read, calculate and verify checksum
          FChecksum := B;
          MS.Read(B, SizeOf(B));
          FChecksum := FChecksum or (B shl 8);

          {$MESSAGE WARN 'TODO: Checksum doesn’t match... — MCO 07-01-2015'}
          if FChecksum <> Checksum then
            SetProblem('Invalid checksum!');

          MS.Read(FCheckSeq, SizeOf(FCheckSeq));
          if FCheckSeq <> FHeader.Sequence then
            SetProblem('Sequence at start and end of pamphlet do not match!');

          Break;
        end;
      end {while};
      if InField <> ifTail then
        SetProblem('Pamphlet incomplete!');
    finally
      MS.Free;
    end;
  finally
    SS.Free;
  end;
  FStream.Position := 0;
end {TZaapSentinelFile.Refresh};

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.Reset;
begin
  FSequence := High(FSequence);
end;

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.RotateChecksum(var CS: Word; const B: Byte);
begin
(*
 (11) Checksums are generated using R16 (Rotate-16bit) type.
      Description:
       Start
       CS word to null.
       Pointer to beginning of string (sequence #)
       Loop: (until 3rd null after the reserved block is processed)
         Rotate left CS 1 bit
         Add the character from string to CS (w/MSB=0)
         Increment pointer
       End loop
*)
  CS := (CS shl 1) or (CS shr 15);
  CS := CS + B;
end {TZaapSentinelFile.RotateChecksum};

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.RotateChecksum(var CS: Word; const B: array of Byte);
var
  i: Integer;
begin
  for i := Low(B) to High(B) do
    RotateChecksum(CS, B[i]);
end {TZaapSentinelFile.RotateChecksum};

{ ------------------------------------------------------------------------------------------------ }
function TZaapSentinelFile.WaitForUpdate(const TimeoutMs, PollIntervalMs: Cardinal): boolean;
var
  pf, pb, pe: Int64;
begin
  Result := True;
  if QueryPerformanceFrequency(pf) and QueryPerformanceCounter(pb) then begin
    pf := pf div 1000;
    while not Refresh do begin
      QueryPerformanceCounter(pe);
      Result := ((pe - pb) div pf) < TimeoutMs;
      if not Result then Exit;
      Sleep(PollIntervalMs);
    end;
  end else begin
    pb := GetTickCount;
    while not Refresh do begin
      Result := (GetTickCount - pb) < TimeoutMs;
      if not Result then Exit;
      Sleep(PollIntervalMs);
    end {while};
  end;
end {TZaapSentinelFile.WaitForUpdate};

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.WriteResponse(const Response: THandshakeResponse;
  const Text: string);
begin
  {$MESSAGE WARN 'TODO: WriteResponse — MCO 06-01-2015'}
end {TZaapSentinelFile.WriteResponse};

{ ------------------------------------------------------------------------------------------------ }
function TZaapSentinelFile.GetFilename: string;
begin
  Result := FStream.FileName;
end;

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.ClearProblem;
begin
  FHasProblem := False;
  FProblem := '';
end;

{ ------------------------------------------------------------------------------------------------ }
procedure TZaapSentinelFile.SetProblem(const Description: string);
begin
  if FHasProblem then
    FProblem := FProblem + sLineBreak
  else
    FHasProblem := True;
  FProblem := FProblem + StringReplace(TrimRight(Description), #10, #10' ', [rfReplaceAll]);
end {TZaapSentinelFile.SetProblem};

{ ------------------------------------------------------------------------------------------------ }
class function TZaapSentinelFile.FindAllSentinels: TStringDynArray;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  procedure AddSentinelPath(const SentinelPath: string);
  var
    FileName: string;
    bFound: boolean;
  begin
    // check for presence of zbar.dat
    if TFile.Exists(SentinelPath) then begin
      bFound := False;
      for FileName in Result do
        if SameFileName(SentinelPath, FileName) then begin
          bFound := True;
          Break;
        end;
      if not bFound then begin
        SetLength(Result, Length(Result) + 1);
        Result[High(Result)] := SentinelPath;
      end;
    end;
  end {AddSentinelPath};
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
var
  Dirs: TStringDynArray;
  Dir, PidFile: string;
  ProcessID: Cardinal;
  ProcessHandle: THandle;
  Executable: string;
  nSize: Cardinal;
begin
  SetLength(Result, 0);

  Dirs := TDirectory.GetDirectories(TPath.GetTempPath, 'ZTMP*');
  for Dir in Dirs do begin
    PidFile := TPath.Combine(Dir, 'ztw.pid');
    if not TFile.Exists(PidFile) then
      Continue;
    with TStreamReader.Create(TFileStream.Create(PidFile, fmOpenRead or fmShareDenyNone), False) do
    try
      OwnStream;
      ProcessID := StrToInt('$' + ReadToEnd);
    finally
      Free;
    end {with TStreamReader};

    // figure out the executable for the given process ID
    ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
    if ProcessHandle = 0 then
      Continue;
    try
      nSize := MAX_PATH;
      SetLength(Executable, nSize);
      if QueryFullProcessImageName(ProcessHandle, 0, PChar(Executable), nSize) then
        SetLength(Executable, nSize)
      else
        Continue; // RaiseLastOSError;
    finally
      CloseHandle(ProcessHandle);
    end;
    if not TFile.Exists(Executable) then
      Continue;

    // figure out the path of the zbar.dat
    AddSentinelPath(TPath.Combine(ExtractFilePath(Executable), 'zbar.dat'));
  end {for};

  // http://fossil.2of4.net/zaap/tktview/ed86fb95ef
  AddSentinelPath(TPath.Combine(GetEnvironmentVariable('APPDATA'), 'ZTreeWin') + '\zbar.dat');
end {TZaapSentinelFile.FindAllSentinels};



end.
