Ken Johnson
a541085a4b
Ask 1 from fpc-binkp consumer thread: non-storage libraries
(fpc-ftn-transport, fpc-binkp, future fpc-comet-proto / fpc-emsi,
SQL-backed messaging like Fastway) only need TFTNAddress, not the
full 1041-line mb.types. Extract to src/mb.address.pas (~90 lines,
only SysUtils) so they can cp a single file into their project.
mb.types continues to uses mb.address so existing callers see the
type transitively -- BUT FPC does not propagate record-field access
through re-export, so consumers that touch TFTNAddress.Zone/Net/
Node/Point directly must add mb.address to their own uses clause.
All 7 in-tree .uni adapters, 2 examples, 5 test harnesses updated.
No behavioural change. Full suite passes, multi-target build
green (x86_64-linux, i386-{linux,freebsd,win32,os2,go32v2}).
947 lines
33 KiB
ObjectPascal
947 lines
33 KiB
ObjectPascal
{
|
|
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.address, 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,
|
|
mb.fmt.hudson, mb.fmt.hudson.uni,
|
|
mb.fmt.goldbase, mb.fmt.goldbase.uni,
|
|
mb.fmt.pcboard, mb.fmt.pcboard.uni,
|
|
mb.fmt.ezycom, mb.fmt.ezycom.uni,
|
|
mb.fmt.wildcat, mb.fmt.wildcat.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;
|
|
|
|
{ Write a Squish message via the low-level API with SEEN-BY / PATH
|
|
placed in the body epilogue (HPT's placement), then reopen via the
|
|
unified API and assert the attr bag was populated from the body
|
|
sweep. Pins the v0.5.4 interop fix against HPT-written Squish. }
|
|
procedure TestSquishHptBodyEpilogue;
|
|
var
|
|
native: TSquishBase;
|
|
smsg: TSquishMessage;
|
|
base: TMessageBase;
|
|
umsg: TUniMessage;
|
|
bp: string;
|
|
begin
|
|
TestBegin('Squish: body-epilogue SEEN-BY/PATH (HPT-style) migrates to attrs on Read');
|
|
CleanDir(SCRATCH + '/hpt');
|
|
ForceDirectories(SCRATCH + '/hpt');
|
|
bp := SCRATCH + '/hpt/rc';
|
|
|
|
{ ---- Init the base via the uni API (creates .sqd / .sqi with a
|
|
valid header), then drop the HPT-style message via the
|
|
native API so we can hand-build s.Body with trail-control
|
|
lines baked in at the tail. ---- }
|
|
base := MessageBaseOpen(mbfSquish, bp, momCreate);
|
|
try
|
|
AssertTrue('init open', base.Open);
|
|
finally
|
|
base.Free;
|
|
end;
|
|
native := TSquishBase.Create(bp);
|
|
try
|
|
AssertTrue('native open', native.OpenReadWrite);
|
|
FillChar(smsg, SizeOf(smsg), 0);
|
|
smsg.WhoFrom := 'Sysop';
|
|
smsg.WhoTo := 'All';
|
|
smsg.Subject := 'HPT-style layout';
|
|
smsg.AzDate := '19 Apr 26 12:00:00';
|
|
smsg.CtrlInfo := #1 + 'MSGID: 20:100/10 deadbeef'; { only MSGID in CtrlInfo }
|
|
smsg.Body := 'Body text.' + #13 +
|
|
'--- tosser' + #13 +
|
|
' * Origin: Node (20:100/10)' + #13 +
|
|
'SEEN-BY: 100/1 10' + #13 +
|
|
#1 + 'PATH: 100/10';
|
|
AssertTrue('native write', native.WriteMessage(smsg));
|
|
finally
|
|
native.Free;
|
|
end;
|
|
|
|
{ ---- Reopen via the unified API, verify attrs are populated ---- }
|
|
base := MessageBaseOpen(mbfSquish, bp, momReadOnly);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
AssertTrue('read', base.ReadMessage(0, umsg));
|
|
AssertEquals('msgid from CtrlInfo',
|
|
'20:100/10 deadbeef', umsg.Attributes.Get('msgid'));
|
|
AssertEquals('seen-by from body',
|
|
'100/1 10', umsg.Attributes.Get('seen-by'));
|
|
AssertEquals('path from body',
|
|
'100/10', umsg.Attributes.Get('path'));
|
|
AssertTrue('body is plain text (Origin line survives)',
|
|
Pos('Origin: Node', umsg.Body) > 0);
|
|
AssertFalse('body no longer carries SEEN-BY:',
|
|
Pos('SEEN-BY:', umsg.Body) > 0);
|
|
AssertFalse('body no longer carries ^APATH:',
|
|
Pos(#1 + 'PATH:', umsg.Body) > 0);
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ --- UpdateMessage tests (NR Message 17 / v0.6.0) ------------------
|
|
The linker use-case: after WriteMessage lands a message at some
|
|
Index, we fetch it back, mutate a reply-chain header field, call
|
|
UpdateMessage, close / reopen, read again, and assert the mutation
|
|
persisted. Body + other content must stay untouched. }
|
|
|
|
procedure TestUpdateMessageJam;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: JAM header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_jam');
|
|
ForceDirectories(SCRATCH + '/upd_jam');
|
|
base := MessageBaseOpen(mbfJam, SCRATCH + '/upd_jam/echo', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'reply-chain update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Attributes.SetValue('msgid', '1:1/1 abcd1234');
|
|
msg.Body := 'hello world';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
{ Now mutate Reply1st / ReplyNext on the written message. }
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('jam.reply1st', 42);
|
|
msg.Attributes.SetInt('jam.replynext', 99);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('reply1st persisted', 42, msg.Attributes.GetInt('jam.reply1st', -1));
|
|
AssertEquals('replynext persisted', 99, msg.Attributes.GetInt('jam.replynext', -1));
|
|
{ JAM writer now appends a trailing CR per FTS-0001 (fix for
|
|
NR Bug #1); the body reads back with the CR still attached. }
|
|
AssertEquals('body untouched', 'hello world'#13, msg.Body);
|
|
AssertEquals('msgid untouched', '1:1/1 abcd1234', msg.Attributes.Get('msgid'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessageSquish;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
rest: TStringDynArray;
|
|
begin
|
|
TestBegin('UpdateMessage: Squish header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_sq');
|
|
ForceDirectories(SCRATCH + '/upd_sq');
|
|
base := MessageBaseOpen(mbfSquish, SCRATCH + '/upd_sq/rc', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'reply-chain update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Attributes.SetValue('msgid', '1:1/1 deadbeef');
|
|
msg.Body := 'hello squish';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('squish.reply1st', 7);
|
|
msg.Attributes.SetList('squish.replynext',
|
|
TStringDynArray.Create('8', '9'));
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('reply1st persisted', 7, msg.Attributes.GetInt('squish.reply1st', -1));
|
|
rest := msg.Attributes.GetList('squish.replynext');
|
|
AssertEquals('replynext count', 2, Length(rest));
|
|
AssertEquals('replynext[0]', '8', rest[0]);
|
|
AssertEquals('replynext[1]', '9', rest[1]);
|
|
AssertEquals('body untouched', 'hello squish', msg.Body);
|
|
AssertEquals('msgid untouched', '1:1/1 deadbeef', msg.Attributes.Get('msgid'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessageMsg;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: *.MSG header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_msg');
|
|
ForceDirectories(SCRATCH + '/upd_msg/');
|
|
base := MessageBaseOpen(mbfMsg, SCRATCH + '/upd_msg/', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'header update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Body := 'hello netmail';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('msg.replyto', 11);
|
|
msg.Attributes.SetInt('msg.nextreply', 22);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('replyto persisted', 11, msg.Attributes.GetInt('msg.replyto', -1));
|
|
AssertEquals('nextreply persisted', 22, msg.Attributes.GetInt('msg.nextreply', -1));
|
|
AssertEquals('body untouched', 'hello netmail', msg.Body);
|
|
AssertEquals('subject untouched', 'header update', msg.Attributes.Get('subject'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessageHudson;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: Hudson header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_hu');
|
|
ForceDirectories(SCRATCH + '/upd_hu');
|
|
base := MessageBaseOpen(mbfHudson, SCRATCH + '/upd_hu', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetInt('board', 1);
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'hudson update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Body := 'hello hudson';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('hudson.prevreply', 33);
|
|
msg.Attributes.SetInt('hudson.nextreply', 44);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('prevreply persisted', 33, msg.Attributes.GetInt('hudson.prevreply', -1));
|
|
AssertEquals('nextreply persisted', 44, msg.Attributes.GetInt('hudson.nextreply', -1));
|
|
AssertEquals('body untouched', 'hello hudson', msg.Body);
|
|
AssertEquals('subject untouched','hudson update', msg.Attributes.Get('subject'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessageGoldBase;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: GoldBase header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_gb');
|
|
ForceDirectories(SCRATCH + '/upd_gb');
|
|
base := MessageBaseOpen(mbfGoldBase, SCRATCH + '/upd_gb', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetInt('board', 1);
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'gold update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Body := 'hello goldbase';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('goldbase.prevreply', 55);
|
|
msg.Attributes.SetInt('goldbase.nextreply', 66);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('prevreply persisted', 55, msg.Attributes.GetInt('goldbase.prevreply', -1));
|
|
AssertEquals('nextreply persisted', 66, msg.Attributes.GetInt('goldbase.nextreply', -1));
|
|
AssertEquals('body untouched', 'hello goldbase', msg.Body);
|
|
AssertEquals('subject untouched','gold update', msg.Attributes.Get('subject'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessagePCBoard;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: PCBoard header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_pc');
|
|
ForceDirectories(SCRATCH + '/upd_pc');
|
|
base := MessageBaseOpen(mbfPCBoard, SCRATCH + '/upd_pc/GEN.MSG', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'pcb update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Body := 'hello pcboard';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('pcb.refnum', 77);
|
|
msg.Attributes.SetInt('pcb.extendedstatus', 42);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('refnum persisted', 77, msg.Attributes.GetInt('pcb.refnum', -1));
|
|
AssertEquals('extendedstatus persisted', 42, msg.Attributes.GetInt('pcb.extendedstatus', -1));
|
|
{ PCBoard uppercases WhoFrom/WhoTo at write time; that's the
|
|
native on-disk convention. We only assert the update didn't
|
|
corrupt the existing on-disk value. }
|
|
AssertEquals('subject untouched', 'pcb update', msg.Attributes.Get('subject'));
|
|
AssertEquals('from untouched', 'ALICE', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
procedure TestUpdateMessageEzyCom;
|
|
var
|
|
base: TMessageBase;
|
|
msg: TUniMessage;
|
|
begin
|
|
TestBegin('UpdateMessage: EzyCom header-only rewrite persists');
|
|
CleanDir(SCRATCH + '/upd_ez');
|
|
ForceDirectories(SCRATCH + '/upd_ez');
|
|
base := MessageBaseOpen(mbfEzyCom, SCRATCH + '/upd_ez', momCreate);
|
|
TEzyComMessageBase(base).Board := 1;
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
msg.Attributes.Clear;
|
|
msg.Attributes.SetInt('board', 1);
|
|
msg.Attributes.SetValue('from', 'Alice');
|
|
msg.Attributes.SetValue('to', 'Bob');
|
|
msg.Attributes.SetValue('subject', 'ezy update');
|
|
msg.Attributes.SetDate('date.written', Now);
|
|
msg.Body := 'hello ezy';
|
|
AssertTrue('write', base.WriteMessage(msg));
|
|
|
|
AssertTrue('read back', base.ReadMessage(0, msg));
|
|
msg.Attributes.SetInt('ezy.prevreply', 88);
|
|
msg.Attributes.SetInt('ezy.nextreply', 99);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('prevreply persisted', 88, msg.Attributes.GetInt('ezy.prevreply', -1));
|
|
AssertEquals('nextreply persisted', 99, msg.Attributes.GetInt('ezy.nextreply', -1));
|
|
AssertEquals('body untouched', 'hello ezy', msg.Body);
|
|
AssertEquals('subject untouched', 'ezy update', msg.Attributes.Get('subject'));
|
|
AssertEquals('from untouched', 'Alice', msg.Attributes.Get('from'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ Wildcat can't be created from scratch (the WC SDK needs a full
|
|
WILDCAT.CFG / conference layout), so this test exercises the
|
|
update path on the vendored sample base at tests/data/wildcat/.
|
|
If the sample is missing -- fresh checkout, non-standard layout --
|
|
the test SKIPs rather than fails. }
|
|
procedure TestUpdateMessageWildcat;
|
|
const
|
|
SRC = 'tests/data/wildcat';
|
|
WC_SCRATCH = '/tmp/ma_wildcat_upd';
|
|
var
|
|
base: TMessageBase;
|
|
adapter: TWildcatMessageBase;
|
|
msg: TUniMessage;
|
|
origCost, newCost: longint;
|
|
begin
|
|
TestBegin('UpdateMessage: Wildcat header-only rewrite persists');
|
|
if not DirectoryExists(SRC) then begin
|
|
WriteLn('SKIP (sample at ', SRC, ' missing)');
|
|
exit;
|
|
end;
|
|
if DirectoryExists(WC_SCRATCH) then
|
|
ExecuteProcess('/bin/sh', ['-c', 'rm -rf "' + WC_SCRATCH + '"']);
|
|
ForceDirectories(WC_SCRATCH);
|
|
if ExecuteProcess('/bin/sh',
|
|
['-c', 'cp -r "' + SRC + '"/. "' + WC_SCRATCH + '"/']) <> 0 then begin
|
|
WriteLn('SKIP (cp -r failed)');
|
|
exit;
|
|
end;
|
|
|
|
base := MessageBaseOpen(mbfWildcat, WC_SCRATCH, momReadWrite);
|
|
adapter := base as TWildcatMessageBase;
|
|
adapter.Conference := 4; { sample has messages in confs 4, 5, 6 }
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
if base.MessageCount = 0 then begin
|
|
WriteLn('SKIP (sample conference 4 has no messages)');
|
|
exit;
|
|
end;
|
|
AssertTrue('read', base.ReadMessage(0, msg));
|
|
origCost := msg.Attributes.GetInt('cost', 0);
|
|
newCost := origCost + 12345;
|
|
msg.Attributes.SetInt('cost', newCost);
|
|
AssertTrue('update', base.UpdateMessage(0, msg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read after update', base.ReadMessage(0, msg));
|
|
AssertEquals('cost persisted', newCost, msg.Attributes.GetInt('cost', -1));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ ============================================================
|
|
NR v0.6.1 bug reports (joint inbox Message 19)
|
|
============================================================ }
|
|
|
|
{ NR Bug #3a: JAM MsgIdCRC must be computed (CRC32 of lowercased
|
|
msgid), not left as zero. External JAM readers (GoldED,
|
|
MsgEd, hptlink) walk the reply chain via MsgIdCRC matching;
|
|
zero breaks threading across every tool that isn't us. }
|
|
procedure TestJamCrcComputed;
|
|
const
|
|
MSGID_VAL = '1:123/456 abcdef01';
|
|
var
|
|
base: TMessageBase;
|
|
adapter: TJamMessageBase;
|
|
umsg: TUniMessage;
|
|
idx: JamIdxRec;
|
|
hdr: JamHdr;
|
|
expectedCRC: longint;
|
|
begin
|
|
TestBegin('JAM MsgIdCRC computed from msgid (NR Bug #3a)');
|
|
CleanDir(SCRATCH + '/jam_crc');
|
|
ForceDirectories(SCRATCH + '/jam_crc');
|
|
base := MessageBaseOpen(mbfJam, SCRATCH + '/jam_crc/echo', momCreate);
|
|
adapter := base as TJamMessageBase;
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
umsg.Attributes.Clear;
|
|
umsg.Attributes.SetValue('from', 'Alice');
|
|
umsg.Attributes.SetValue('to', 'Bob');
|
|
umsg.Attributes.SetValue('subject', 'crc-check');
|
|
umsg.Attributes.SetDate('date.written', Now);
|
|
umsg.Attributes.SetValue('msgid', MSGID_VAL);
|
|
umsg.Body := 'hello';
|
|
AssertTrue('write', base.WriteMessage(umsg));
|
|
base.Close;
|
|
|
|
{ Verify on disk that MsgIdCRC is the expected CRC32 value
|
|
and PasswordCRC is the no-password sentinel. }
|
|
expectedCRC := TJamBase.CalcMsgIdCRC(MSGID_VAL);
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read index', adapter.Native.ReadIndex(0, idx));
|
|
AssertTrue('read header', adapter.Native.ReadHeader(idx.HdrOffset, hdr));
|
|
AssertEquals('MsgIdCRC = CRC32(lowercase msgid)',
|
|
expectedCRC, hdr.MsgIdCRC);
|
|
AssertEquals('ReplyCRC = 0xFFFFFFFF (no REPLY kludge)',
|
|
longint($FFFFFFFF), hdr.ReplyCRC);
|
|
AssertEquals('PasswordCRC = 0xFFFFFFFF (no password)',
|
|
longint($FFFFFFFF), hdr.PasswordCRC);
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ NR Bug #1: trailing CR on body must be preserved through
|
|
JAM write. HPT keeps it; the library was stripping it. }
|
|
procedure TestJamBodyTrailingCR;
|
|
var
|
|
base: TMessageBase;
|
|
adapter: TJamMessageBase;
|
|
umsg: TUniMessage;
|
|
idx: JamIdxRec;
|
|
hdr: JamHdr;
|
|
stored: AnsiString;
|
|
begin
|
|
TestBegin('JAM body preserves trailing CR on write (NR Bug #1)');
|
|
CleanDir(SCRATCH + '/jam_cr');
|
|
ForceDirectories(SCRATCH + '/jam_cr');
|
|
base := MessageBaseOpen(mbfJam, SCRATCH + '/jam_cr/echo', momCreate);
|
|
adapter := base as TJamMessageBase;
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
umsg.Attributes.Clear;
|
|
umsg.Attributes.SetValue('from', 'A');
|
|
umsg.Attributes.SetValue('to', 'B');
|
|
umsg.Attributes.SetValue('subject', 'cr-check');
|
|
umsg.Attributes.SetDate('date.written', Now);
|
|
{ Body without trailing CR -- library should add one. }
|
|
umsg.Body := 'No CR here';
|
|
AssertTrue('write', base.WriteMessage(umsg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read index', adapter.Native.ReadIndex(0, idx));
|
|
AssertTrue('read header', adapter.Native.ReadHeader(idx.HdrOffset, hdr));
|
|
stored := adapter.Native.ReadBody(hdr.TxtOffset, hdr.TxtLen);
|
|
AssertTrue('body ends with #13',
|
|
(Length(stored) > 0) and (stored[Length(stored)] = #13));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ NR Bug #4b: CHRS and TID attrs must survive JAM write as
|
|
JAM_FTSKLUDGE subfields. Losing CHRS corrupts non-ASCII
|
|
display. }
|
|
procedure TestJamChrsTidRoundTrip;
|
|
var
|
|
base: TMessageBase;
|
|
umsg: TUniMessage;
|
|
begin
|
|
TestBegin('JAM preserves CHRS + TID via FTSKLUDGE subfield (NR Bug #4b)');
|
|
CleanDir(SCRATCH + '/jam_chrs');
|
|
ForceDirectories(SCRATCH + '/jam_chrs');
|
|
base := MessageBaseOpen(mbfJam, SCRATCH + '/jam_chrs/echo', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
umsg.Attributes.Clear;
|
|
umsg.Attributes.SetValue('from', 'A');
|
|
umsg.Attributes.SetValue('to', 'B');
|
|
umsg.Attributes.SetValue('subject', 'chrs-test');
|
|
umsg.Attributes.SetDate('date.written', Now);
|
|
umsg.Attributes.SetValue('chrs', 'LATIN-1 2');
|
|
umsg.Attributes.SetValue('tid', 'TestTosser 1.0');
|
|
umsg.Body := 'body';
|
|
AssertTrue('write', base.WriteMessage(umsg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read', base.ReadMessage(0, umsg));
|
|
AssertEquals('chrs round-trips',
|
|
'LATIN-1 2', umsg.Attributes.Get('chrs'));
|
|
AssertEquals('tid round-trips',
|
|
'TestTosser 1.0', umsg.Attributes.Get('tid'));
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ Hudson (and by extension GoldBase/PCBoard/EzyCom/Wildcat):
|
|
MSGID / PID / SEEN-BY / PATH / etc. now round-trip through
|
|
SplitKludgeBlob on Read + BuildKludgePrefix on Write, so a
|
|
consumer can read the attr bag and get real values. }
|
|
procedure TestHudsonKludgeRoundTrip;
|
|
var
|
|
base: TMessageBase;
|
|
umsg: TUniMessage;
|
|
begin
|
|
TestBegin('Hudson kludge round-trip (MSGID/PID/SEEN-BY/CHRS)');
|
|
CleanDir(SCRATCH + '/hu_kludge');
|
|
ForceDirectories(SCRATCH + '/hu_kludge');
|
|
base := MessageBaseOpen(mbfHudson, SCRATCH + '/hu_kludge', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
umsg.Attributes.Clear;
|
|
umsg.Attributes.SetInt('board', 1);
|
|
umsg.Attributes.SetValue('from', 'Alice');
|
|
umsg.Attributes.SetValue('to', 'Bob');
|
|
umsg.Attributes.SetValue('subject', 'kludge test');
|
|
umsg.Attributes.SetDate('date.written', Now);
|
|
umsg.Attributes.SetValue('msgid', '1:1/1 deadbeef');
|
|
umsg.Attributes.SetValue('pid', 'TestEditor 1.0');
|
|
umsg.Attributes.SetValue('chrs', 'UTF-8 4');
|
|
umsg.Attributes.SetValue('tzutc', '0100');
|
|
umsg.Attributes.SetValue('seen-by', '1/1 2');
|
|
umsg.Attributes.SetValue('path', '1/1');
|
|
umsg.Body := 'user text';
|
|
AssertTrue('write', base.WriteMessage(umsg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read', base.ReadMessage(0, umsg));
|
|
AssertEquals('msgid', '1:1/1 deadbeef', umsg.Attributes.Get('msgid'));
|
|
AssertEquals('pid', 'TestEditor 1.0', umsg.Attributes.Get('pid'));
|
|
AssertEquals('chrs', 'UTF-8 4', umsg.Attributes.Get('chrs'));
|
|
AssertEquals('tzutc', '0100', umsg.Attributes.Get('tzutc'));
|
|
AssertEquals('seen-by', '1/1 2', umsg.Attributes.Get('seen-by'));
|
|
AssertEquals('path', '1/1', umsg.Attributes.Get('path'));
|
|
AssertEquals('body is user text only',
|
|
'user text', umsg.Body);
|
|
finally
|
|
base.Free;
|
|
end;
|
|
TestOK;
|
|
end;
|
|
|
|
{ GoldBase shares the pattern -- spot-check msgid + seen-by. }
|
|
procedure TestGoldBaseKludgeRoundTrip;
|
|
var
|
|
base: TMessageBase;
|
|
umsg: TUniMessage;
|
|
begin
|
|
TestBegin('GoldBase kludge round-trip (msgid + seen-by)');
|
|
CleanDir(SCRATCH + '/gb_kludge');
|
|
ForceDirectories(SCRATCH + '/gb_kludge');
|
|
base := MessageBaseOpen(mbfGoldBase, SCRATCH + '/gb_kludge', momCreate);
|
|
try
|
|
AssertTrue('open', base.Open);
|
|
umsg.Attributes.Clear;
|
|
umsg.Attributes.SetInt('board', 1);
|
|
umsg.Attributes.SetValue('from', 'Alice');
|
|
umsg.Attributes.SetValue('to', 'Bob');
|
|
umsg.Attributes.SetValue('subject', 'gb kludge test');
|
|
umsg.Attributes.SetDate('date.written', Now);
|
|
umsg.Attributes.SetValue('msgid', '2:2/2 beefcafe');
|
|
umsg.Attributes.SetValue('seen-by', '2/2 5');
|
|
umsg.Body := 'gb body';
|
|
AssertTrue('write', base.WriteMessage(umsg));
|
|
base.Close;
|
|
|
|
AssertTrue('reopen', base.Open);
|
|
AssertTrue('read', base.ReadMessage(0, umsg));
|
|
AssertEquals('msgid', '2:2/2 beefcafe', umsg.Attributes.Get('msgid'));
|
|
AssertEquals('seen-by', '2/2 5', umsg.Attributes.Get('seen-by'));
|
|
AssertEquals('body is user text only', 'gb body', umsg.Body);
|
|
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;
|
|
TestSquishHptBodyEpilogue;
|
|
TestUpdateMessageJam;
|
|
TestUpdateMessageSquish;
|
|
TestUpdateMessageMsg;
|
|
TestUpdateMessageHudson;
|
|
TestUpdateMessageGoldBase;
|
|
TestUpdateMessagePCBoard;
|
|
TestUpdateMessageEzyCom;
|
|
TestUpdateMessageWildcat;
|
|
TestJamCrcComputed;
|
|
TestJamBodyTrailingCR;
|
|
TestJamChrsTidRoundTrip;
|
|
TestHudsonKludgeRoundTrip;
|
|
TestGoldBaseKludgeRoundTrip;
|
|
|
|
Halt(TestsSummary);
|
|
end.
|