fpc-msgbase/tests/test_consumer_round1.pas

{
  test_consumer_round1.pas - regression tests for 0.3.5 changes
  driven by integration feedback from NetReader/Fimail.

  Covers:
  1. INTL / FMPT / TOPT FTSC kludge round-trip on JAM, MSG, PKT,
     and Squish (the four formats whose capability lists include
     them).
  2. Unified `kludge.<name>` namespace -- unknown FTSC kludges
     land under kludge.<lowername> regardless of which backend
     stored them, so consumers don't need to switch on format
     to find passthrough kludges.
  3. msg.Attributes['area'] auto-populated from base.AreaTag on
     Read when caller passed the tag to MessageBaseOpen.
  4. Attributes.GetList / SetList / AppendListItem multi-line
     accessors (so consumers don't roll their own #13 split).

  Items 5+ (PKT-related: explicit raise on Write, CreateFromStream
  / CreateNewToStream stream targets) moved to fpc-ftn-transport's
  test_pkt_writer.pas in fpc-msgbase 0.4.0 along with the PKT
  code itself.
}

program test_consumer_round1;

{$mode objfpc}{$H+}
{$modeswitch advancedrecords}

uses
  Classes, SysUtils,
  testutil,
  mb.types, mb.events, mb.api, mb.kludge,
  mb.fmt.jam,    mb.fmt.jam.uni,
  mb.fmt.squish, mb.fmt.squish.uni,
  mb.fmt.msg,    mb.fmt.msg.uni;

const
  SCRATCH = '/tmp/ma_consumer_r1';

procedure CleanDir(const APath: string);
var
  sr: TSearchRec;
begin
  if not DirectoryExists(APath) then exit;
  if FindFirst(APath + '/*', faAnyFile, sr) = 0 then
  try
    repeat
      if (sr.Attr and faDirectory) = 0 then
        DeleteFile(APath + '/' + sr.Name);
    until FindNext(sr) <> 0;
  finally
    FindClose(sr);
  end;
end;

function MakeIntlMsg: TUniMessage;
begin
  Result.Attributes.Clear;
  Result.Attributes.SetValue('from',    'Cross-Zone Sender');
  Result.Attributes.SetValue('to',      'Cross-Zone Recipient');
  Result.Attributes.SetValue('subject', 'INTL kludge test');
  Result.Attributes.SetDate('date.written', Now);
  Result.Attributes.SetAddr('addr.orig', MakeFTNAddress(2, 100, 200, 0));
  Result.Attributes.SetAddr('addr.dest', MakeFTNAddress(1, 100, 300, 1));
  Result.Attributes.SetValue('intl', '1:100/300 2:100/200');
  Result.Attributes.SetValue('fmpt', '0');
  Result.Attributes.SetValue('topt', '1');
  Result.Attributes.SetValue('msgid', '2:100/200 deadbeef');
  Result.Attributes.SetValue('kludge.xfoo', 'unknown-passthrough');
  Result.Body := 'Cross-zone netmail body.';
end;

procedure TestIntlRoundTrip(AFormat: TMsgBaseFormat;
                            const APath, AName: string);
var
  base: TMessageBase;
  wmsg, rmsg: TUniMessage;
begin
  TestBegin(AName);
  ForceDirectories(ExtractFilePath(APath));
  CleanDir(ExtractFilePath(APath));
  wmsg := MakeIntlMsg;
  base := MessageBaseOpen(AFormat, APath, momCreate);
  try
    AssertTrue('Open create', base.Open);
    AssertTrue('Write', base.WriteMessage(wmsg));
  finally
    base.Close;
    base.Free;
  end;
  base := MessageBaseOpen(AFormat, APath, momReadOnly);
  try
    AssertTrue('Open read', base.Open);
    AssertTrue('Read[0]', base.ReadMessage(0, rmsg));
    AssertEquals('intl preserved',  '1:100/300 2:100/200',
                 rmsg.Attributes.Get('intl'));
    AssertEquals('fmpt preserved',  '0', rmsg.Attributes.Get('fmpt'));
    AssertEquals('topt preserved',  '1', rmsg.Attributes.Get('topt'));
    AssertEquals('msgid preserved', '2:100/200 deadbeef',
                 rmsg.Attributes.Get('msgid'));
    AssertEquals('unknown kludge preserved as kludge.xfoo',
                 'unknown-passthrough',
                 rmsg.Attributes.Get('kludge.xfoo'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestAreaAutoPop;
var
  base: TMessageBase;
  msg:  TUniMessage;
begin
  TestBegin('AreaTag auto-populates msg.Attributes[area] on Read');
  ForceDirectories(SCRATCH + '/area');
  CleanDir(SCRATCH + '/area');

  { Seed JAM with one message.  Use a stable path and set
    AreaTag via the property setter so we can flip it on/off
    between sessions without changing path resolution. }
  base := MessageBaseOpen(mbfJam, SCRATCH + '/area/echo', momCreate);
  try
    AssertTrue('Open create', base.Open);
    msg.Attributes.Clear;
    msg.Attributes.SetValue('from',    'A');
    msg.Attributes.SetValue('to',      'B');
    msg.Attributes.SetValue('subject', 'hi');
    msg.Body := 'body';
    AssertTrue('Write', base.WriteMessage(msg));
  finally
    base.Close;
    base.Free;
  end;

  { Reopen with AreaTag set via property: read should auto-fill area. }
  base := MessageBaseOpen(mbfJam, SCRATCH + '/area/echo', momReadOnly);
  try
    base.AreaTag := 'TEST.AREA';
    AssertTrue('Open ro', base.Open);
    AssertTrue('Read[0]', base.ReadMessage(0, msg));
    AssertEquals('area auto-populated', 'TEST.AREA',
                 msg.Attributes.Get('area'));
  finally
    base.Close;
    base.Free;
  end;

  { Reopen with no AreaTag: read should leave area empty. }
  base := MessageBaseOpen(mbfJam, SCRATCH + '/area/echo', momReadOnly);
  try
    AssertTrue('Open ro no tag', base.Open);
    AssertTrue('Read[0] no tag', base.ReadMessage(0, msg));
    AssertEquals('area empty when no AreaTag', '',
                 msg.Attributes.Get('area'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestGetSetListAccessors;
var
  attrs: TMsgAttributes;
  list:  TStringDynArray;
begin
  TestBegin('Attributes.GetList / SetList / AppendListItem');
  attrs.Clear;

  { GetList on empty key -> empty array. }
  list := attrs.GetList('seen-by');
  AssertEquals('empty list length', 0, Length(list));

  { SetList -> stored joined with #13. }
  SetLength(list, 3);
  list[0] := '1/100 200 300';
  list[1] := '1/200 100';
  list[2] := '2/50 60';
  attrs.SetList('seen-by', list);
  AssertEquals('joined storage matches',
               '1/100 200 300'#13'1/200 100'#13'2/50 60',
               attrs.Get('seen-by'));

  { GetList round-trips. }
  list := attrs.GetList('seen-by');
  AssertEquals('list length',     3, Length(list));
  AssertEquals('list[0]', '1/100 200 300', list[0]);
  AssertEquals('list[1]', '1/200 100',     list[1]);
  AssertEquals('list[2]', '2/50 60',       list[2]);

  { AppendListItem grows. }
  attrs.AppendListItem('seen-by', '3/777');
  list := attrs.GetList('seen-by');
  AssertEquals('appended length', 4, Length(list));
  AssertEquals('appended item',   '3/777', list[3]);

  { Empty SetList removes the key. }
  SetLength(list, 0);
  attrs.SetList('seen-by', list);
  AssertFalse('empty SetList removed key', attrs.Has('seen-by'));
  TestOK;
end;

{ TestPktWriteRaisesExplicitly + TestPktCreateFromStream moved
  to fpc-ftn-transport's tests/test_pkt_writer.pas along with
  the PKT code itself in fpc-msgbase 0.4.0. }

procedure TestSyncWriteable;
{ NR durability gap (2026-04-18): Sync should be callable on
  every writable backend without crashing.  Doesn't verify the
  syscall count -- just exercises the path. }
var
  base: TMessageBase;
  msg: TUniMessage;
  formats: array[0..1] of TMsgBaseFormat = (mbfJam, mbfSquish);
  paths:   array[0..1] of AnsiString = ('/sync/jam/echo', '/sync/sq/sq');
  raised: boolean;
  i: integer;
begin
  TestBegin('Sync: callable on writable backends; raises after Close');
  for i := 0 to High(formats) do begin
    ForceDirectories(SCRATCH + '/sync');
    base := MessageBaseOpen(formats[i], SCRATCH + paths[i], momCreate);
    try
      AssertTrue('open ' + paths[i], base.Open);
      msg.Attributes.Clear;
      msg.Attributes.SetValue('from', 'A');
      msg.Attributes.SetValue('to',   'B');
      msg.Attributes.SetValue('subject', 'sync-check');
      msg.Body := 'body';
      AssertTrue('write', base.WriteMessage(msg));
      base.Sync;                  { live: must not raise }
      base.Close;
      raised := false;
      try base.Sync;
      except on E: Exception do raised := true; end;
      AssertTrue('Sync after Close raises', raised);
    finally
      base.Free;
    end;
  end;
  TestOK;
end;

procedure TestSquishReplyChain;
var
  base: TMessageBase;
  wmsg, rmsg: TUniMessage;
  rest: TStringDynArray;
begin
  TestBegin('Squish reply-chain round-trip (reply1st + replynext list)');
  CleanDir(SCRATCH + '/replies');
  ForceDirectories(SCRATCH + '/replies');
  base := MessageBaseOpen(mbfSquish, SCRATCH + '/replies/rc', momCreate);
  try
    AssertTrue('open', base.Open);
    wmsg.Attributes.Clear;
    wmsg.Attributes.SetValue('from',    'Parent');
    wmsg.Attributes.SetValue('to',      'All');
    wmsg.Attributes.SetValue('subject', 'reply-chain test');
    wmsg.Attributes.SetDate('date.written', Now);
    wmsg.Attributes.SetInt('squish.replyto',  0);
    wmsg.Attributes.SetInt('squish.reply1st', 101);
    wmsg.Attributes.SetList('squish.replynext',
      TStringDynArray.Create('102', '103', '104'));
    wmsg.Body := 'parent message';
    AssertTrue('write', base.WriteMessage(wmsg));
    base.Close;

    AssertTrue('reopen', base.Open);
    AssertTrue('read',   base.ReadMessage(0, rmsg));
    AssertEquals('reply1st', 101, rmsg.Attributes.GetInt('squish.reply1st', -1));
    rest := rmsg.Attributes.GetList('squish.replynext');
    AssertEquals('replynext count', 3, Length(rest));
    AssertEquals('replynext[0]',    '102', rest[0]);
    AssertEquals('replynext[1]',    '103', rest[1]);
    AssertEquals('replynext[2]',    '104', rest[2]);
  finally
    base.Free;
  end;
  TestOK;
end;

begin
  WriteLn('fpc-msgbase: 0.3.5 consumer-feedback regression tests');
  WriteLn;
  ForceDirectories(SCRATCH);

  TestIntlRoundTrip(mbfJam,    SCRATCH + '/intl/jam/echo',
                    'INTL/FMPT/TOPT round-trip: JAM');
  TestIntlRoundTrip(mbfSquish, SCRATCH + '/intl/squish/sq',
                    'INTL/FMPT/TOPT round-trip: Squish');
  TestIntlRoundTrip(mbfMsg,    SCRATCH + '/intl/msg/',
                    'INTL/FMPT/TOPT round-trip: MSG');
  TestAreaAutoPop;
  TestGetSetListAccessors;
  TestSyncWriteable;
  TestSquishReplyChain;

  Halt(TestsSummary);
end.