kenjreno/fpc-msgbase
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Phase 4: kludge round-trip + cross-format capability tests

Browse Source 
Adds tests/test_roundtrip_attrs.pas covering:

1. Capabilities API smoke test — confirms SupportsAttribute('msgid')
   returns true on JAM/Squish/MSG/PKT, false on Hudson/GoldBase/
   EzyCom/Wildcat/PCBoard. Confirms backend-private keys are gated
   correctly (Squish.SupportsAttribute('jam.msgidcrc') = false).

2. Per-format kludge round-trip across all 5 storage formats —
   builds a synthetic message with universal headers + FTSC kludges
   (msgid, replyid, pid, flags, multi-line seen-by + path), writes,
   reopens, reads back, asserts every key the backend's capability
   list advertises survives byte-for-byte. Backends that don't
   support a given key are silently skipped via SupportsAttribute
   gating so the test exercises each format's actual contract.

3. Cross-format JAM → Squish copy — seeds JAM with the kludge
   message, copies to a fresh Squish base via the unified API,
   reopens both, asserts:
   - intersection of capabilities lists is preserved verbatim
     (msgid, seen-by, path, etc. all survive JAM → Squish)
   - jam.* keys not in Squish's capability list are dropped
     (no silent corruption of Squish's data with foreign keys)

Result: 7/7 new tests pass. Total suite now 31/31 across 8 programs.
This is the regression suite that locks the Body+Attributes contract
and proves the showstopper fix holds across every backend.

Hooked into run_tests.sh so CI catches future drift.
This commit is contained in:
Ken Johnson
2026-04-17 14:32:38 -07:00
parent a187c63c10
commit d7e58932e9
2 changed files with 357 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
run_tests.sh
View File

@@ -39,6 +39,7 @@ run() {
echo "Building tests..."
compile tests/test_read.pas
compile tests/test_roundtrip.pas
compile tests/test_roundtrip_attrs.pas
compile tests/test_lock.pas
compile tests/test_batch.pas
compile tests/test_wildcat.pas
@@ -49,6 +50,7 @@ echo
echo "Running tests..."
run test_read
run test_roundtrip
run test_roundtrip_attrs
run test_lock
run test_batch
run test_wildcat

355
tests/test_roundtrip_attrs.pas Normal file
View File

@@ -0,0 +1,355 @@
{
test_roundtrip_attrs.pas - verify the new Body+Attributes data
model preserves kludges (msgid, seen-by, path, etc.) across
Read/Write cycles, and that cross-format copies preserve every
attribute the destination's capabilities advertise.
Catches the showstopper bug that prompted this design: previously
every adapter dropped MSGID/ReplyID/PID/Flags/SEEN-BY/PATH on the
way through TUniMessage. These assertions block any future
regression.
Two test groups:
1. Per-format kludge round-trip -- write a message with kludge
attributes, read it back, confirm preserved. Skipped per
backend if SupportsAttribute('msgid') = false.
2. Cross-format copy -- copy JAM -> Squish, walk each message
and assert: every attribute the destination's
ClassSupportedAttributes lists is preserved verbatim;
attributes the destination lacks are simply absent (not
silently corrupting the destination's data).
}
program test_roundtrip_attrs;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
uses
SysUtils,
testutil,
ma.types, ma.events, ma.api,
ma.fmt.hudson, ma.fmt.hudson.uni,
ma.fmt.jam, ma.fmt.jam.uni,
ma.fmt.squish, ma.fmt.squish.uni,
ma.fmt.msg, ma.fmt.msg.uni,
ma.fmt.pkt, ma.fmt.pkt.uni,
ma.fmt.pcboard, ma.fmt.pcboard.uni,
ma.fmt.ezycom, ma.fmt.ezycom.uni,
ma.fmt.goldbase, ma.fmt.goldbase.uni;
const
SCRATCH_ROOT = '/tmp/ma_roundtrip_attrs';
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;
{ Build a synthetic message exercising universal headers + FTSC
kludges + a couple of multi-line attributes. Backends ignore
attributes they don't support; we only assert preservation of
keys their capability list advertises. }
function MakeKludgeMsg: TUniMessage;
begin
Result.Attributes.Clear;
Result.Attributes.SetValue('from', 'Test User');
Result.Attributes.SetValue('to', 'All');
Result.Attributes.SetValue('subject', 'Kludge round-trip');
Result.Attributes.SetDate('date.written',
EncodeDate(2026, 4, 17) + EncodeTime(15, 30, 0, 0));
Result.Attributes.SetAddr('addr.orig', MakeFTNAddress(1, 100, 200, 0));
Result.Attributes.SetAddr('addr.dest', MakeFTNAddress(1, 100, 300, 0));
Result.Attributes.SetBool('attr.local', true);
Result.Attributes.SetBool('attr.echo', true);
Result.Attributes.SetValue('msgid', '1:100/200 deadbeef');
Result.Attributes.SetValue('replyid', '1:100/200 cafef00d');
Result.Attributes.SetValue('pid', 'fpc-msgbase 0.2');
Result.Attributes.SetValue('flags', 'NPD');
{ Multi-line attributes use #13 between lines. }
Result.Attributes.SetValue('seen-by',
'1/100 200 300' + #13 + '1/200 100');
Result.Attributes.SetValue('path',
'1/100' + #13 + '1/200');
Result.Body := 'This is the user-visible body. No kludges here.';
end;
procedure RoundTripKludges(AFormat: TMsgBaseFormat; const APath: string;
const ATestName: string);
var
base: TMessageBase;
wmsg, rmsg: TUniMessage;
preCount: longint;
procedure CheckIfSupported(const Key, Expected: AnsiString);
begin
if base.SupportsAttribute(Key) then
AssertEquals(Key, Expected, rmsg.Attributes.Get(Key));
end;
begin
TestBegin(ATestName);
ForceDirectories(ExtractFilePath(APath));
CleanDir(ExtractFilePath(APath));
wmsg := MakeKludgeMsg;
base := MessageBaseOpen(AFormat, APath, momCreate);
try
AssertTrue('Open (write)', base.Open);
preCount := base.MessageCount;
AssertTrue('WriteMessage', base.WriteMessage(wmsg));
finally
base.Close;
base.Free;
end;
base := MessageBaseOpen(AFormat, APath, momReadOnly);
try
AssertTrue('Open (read)', base.Open);
AssertTrue('ReadMessage', base.ReadMessage(preCount, rmsg));
{ Universal headers every backend supports. }
CheckIfSupported('from', 'Test User');
CheckIfSupported('to', 'All');
CheckIfSupported('subject', 'Kludge round-trip');
{ FTSC kludges -- only check on backends that support them.
Hudson/GoldBase/EzyCom/Wildcat/PCBoard return false from
SupportsAttribute('msgid') so they're skipped here. }
CheckIfSupported('msgid', '1:100/200 deadbeef');
CheckIfSupported('replyid', '1:100/200 cafef00d');
CheckIfSupported('pid', 'fpc-msgbase 0.2');
CheckIfSupported('flags', 'NPD');
CheckIfSupported('seen-by', '1/100 200 300' + #13 + '1/200 100');
CheckIfSupported('path', '1/100' + #13 + '1/200');
finally
base.Close;
base.Free;
end;
TestOK;
end;
{ Cross-format copy: walk a JAM source, write each message to a
fresh Squish destination, then read both back and compare the
intersection of their SupportedAttributes lists. Verifies the
capability contract: keys both formats know are preserved
byte-for-byte; keys the destination doesn't know are dropped. }
procedure CrossFormatCopy;
var
src, dst: TMessageBase;
i, n: longint;
smsg, dmsg: TUniMessage;
srcKeys, dstKeys: TStringDynArray;
ki, kj: longint;
k: AnsiString;
inSrc, inDst: boolean;
intersect: array of AnsiString;
intCount, droppedCount: longint;
begin
TestBegin('Cross-format copy: JAM source -> fresh Squish destination');
ForceDirectories(SCRATCH_ROOT + '/cross/jam');
CleanDir(SCRATCH_ROOT + '/cross/jam');
ForceDirectories(SCRATCH_ROOT + '/cross/squish');
CleanDir(SCRATCH_ROOT + '/cross/squish');
{ Seed JAM source with one rich message. }
src := MessageBaseOpen(mbfJam,
SCRATCH_ROOT + '/cross/jam/echo',
momCreate);
try
AssertTrue('Open JAM source (write)', src.Open);
smsg := MakeKludgeMsg;
AssertTrue('Seed JAM source', src.WriteMessage(smsg));
finally
src.Close;
src.Free;
end;
{ Open both for the copy. }
src := MessageBaseOpen(mbfJam,
SCRATCH_ROOT + '/cross/jam/echo',
momReadOnly);
dst := MessageBaseOpen(mbfSquish,
SCRATCH_ROOT + '/cross/squish/sq',
momCreate);
try
AssertTrue('Open JAM source (read)', src.Open);
AssertTrue('Open Squish dest', dst.Open);
n := src.MessageCount;
AssertTrue('Source has messages', n > 0);
{ Compute intersection + count drops. }
srcKeys := src.SupportedAttributes;
dstKeys := dst.SupportedAttributes;
SetLength(intersect, 0);
droppedCount := 0;
for ki := 0 to High(srcKeys) do begin
k := srcKeys[ki];
inDst := False;
for kj := 0 to High(dstKeys) do
if LowerCase(dstKeys[kj]) = LowerCase(k) then begin
inDst := True; break;
end;
if inDst then begin
SetLength(intersect, Length(intersect) + 1);
intersect[High(intersect)] := k;
end else
Inc(droppedCount);
end;
AssertTrue('Intersection non-empty', Length(intersect) > 0);
AssertTrue('Some keys dropped (jam.* not in Squish)',
droppedCount > 0);
{ Copy. }
for i := 0 to n - 1 do begin
AssertTrue('Read source ' + IntToStr(i), src.ReadMessage(i, smsg));
AssertTrue('Write dest ' + IntToStr(i), dst.WriteMessage(smsg));
end;
finally
dst.Close;
dst.Free;
src.Close;
src.Free;
end;
{ Reopen both for verification. }
src := MessageBaseOpen(mbfJam,
SCRATCH_ROOT + '/cross/jam/echo',
momReadOnly);
dst := MessageBaseOpen(mbfSquish,
SCRATCH_ROOT + '/cross/squish/sq',
momReadOnly);
try
AssertTrue('Reopen JAM source', src.Open);
AssertTrue('Reopen Squish dest', dst.Open);
AssertEquals('Dest message count matches source',
src.MessageCount, dst.MessageCount);
AssertTrue('Read source [0]', src.ReadMessage(0, smsg));
AssertTrue('Read dest [0]', dst.ReadMessage(0, dmsg));
intCount := 0;
for ki := 0 to High(intersect) do begin
k := intersect[ki];
{ Skip keys whose value the destination computes itself
(e.g. msg.num, squish.umsgid -- written by the backend
on Write). Verify only "data" attributes. }
if (k = 'msg.num') or (k = 'squish.umsgid') then continue;
{ Skip date.received -- not preserved across copies because
it's filled in by the receiving system, not the sender. }
if k = 'date.received' then continue;
inSrc := smsg.Attributes.Has(k);
inDst := dmsg.Attributes.Has(k);
if inSrc and inDst then begin
AssertEquals('intersect key preserved: ' + k,
smsg.Attributes.Get(k),
dmsg.Attributes.Get(k));
Inc(intCount);
end;
end;
AssertTrue('At least 5 intersect keys verified', intCount >= 5);
{ Sanity: jam-specific keys we set in source should NOT exist
in dest (they're not in Squish's capability list). }
AssertEquals('jam.dateprocessed not in Squish dest',
'', dmsg.Attributes.Get('jam.dateprocessed', ''));
finally
dst.Close;
dst.Free;
src.Close;
src.Free;
end;
TestOK;
end;
procedure CapabilitiesSmokeTest;
var
jam, squish, hudson: TMessageBase;
begin
TestBegin('Capabilities API: SupportsAttribute distinguishes formats');
ForceDirectories(SCRATCH_ROOT + '/cap/jam');
ForceDirectories(SCRATCH_ROOT + '/cap/squish');
ForceDirectories(SCRATCH_ROOT + '/cap/hudson');
jam := MessageBaseOpen(mbfJam,
SCRATCH_ROOT + '/cap/jam/echo',
momCreate);
squish := MessageBaseOpen(mbfSquish,
SCRATCH_ROOT + '/cap/squish/sq',
momCreate);
hudson := MessageBaseOpen(mbfHudson,
SCRATCH_ROOT + '/cap/hudson/',
momCreate);
try
{ JAM supports kludges. }
AssertTrue('JAM SupportsAttribute(msgid)',
jam.SupportsAttribute('msgid'));
AssertTrue('JAM SupportsAttribute(seen-by)',
jam.SupportsAttribute('seen-by'));
AssertTrue('JAM SupportsAttribute(jam.msgidcrc)',
jam.SupportsAttribute('jam.msgidcrc'));
{ Squish supports its own keys, not JAM-private ones. }
AssertTrue('Squish SupportsAttribute(msgid)',
squish.SupportsAttribute('msgid'));
AssertTrue('Squish SupportsAttribute(squish.umsgid)',
squish.SupportsAttribute('squish.umsgid'));
AssertEquals('Squish SupportsAttribute(jam.msgidcrc) = false',
'False',
BoolToStr(squish.SupportsAttribute('jam.msgidcrc'),
True));
{ Hudson does not carry FTSC kludges. }
AssertEquals('Hudson SupportsAttribute(msgid) = false',
'False',
BoolToStr(hudson.SupportsAttribute('msgid'), True));
AssertEquals('Hudson SupportsAttribute(seen-by) = false',
'False',
BoolToStr(hudson.SupportsAttribute('seen-by'), True));
AssertTrue('Hudson SupportsAttribute(board)',
hudson.SupportsAttribute('board'));
finally
hudson.Free;
squish.Free;
jam.Free;
end;
TestOK;
end;
begin
WriteLn('fpc-msgbase: Body+Attributes round-trip + capabilities tests');
WriteLn;
ForceDirectories(SCRATCH_ROOT);
CapabilitiesSmokeTest;
RoundTripKludges(mbfHudson, SCRATCH_ROOT + '/hudson/', 'Hudson kludge round-trip');
RoundTripKludges(mbfJam, SCRATCH_ROOT + '/jam/echo', 'JAM kludge round-trip');
RoundTripKludges(mbfSquish, SCRATCH_ROOT + '/squish/sq', 'Squish kludge round-trip');
RoundTripKludges(mbfMsg, SCRATCH_ROOT + '/msg/', 'FTS-1 MSG kludge round-trip');
RoundTripKludges(mbfGoldBase, SCRATCH_ROOT + '/goldbase/', 'GoldBase kludge round-trip');
CrossFormatCopy;
Halt(TestsSummary);
end.