From e876d98b83bb48d64320f2cf14cbaaa3e119e47c Mon Sep 17 00:00:00 2001 From: Ken Johnson Date: Sat, 18 Apr 2026 09:14:33 -0700 Subject: [PATCH] 0.3.5: ma.kludge shared helper, INTL/FMPT/TOPT, area auto-pop, list helpers, PKT polish MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Five consumer-feedback items, one milestone: (1) Shared FTSC kludge plumbing in src/ma.kludge.pas ParseKludgeLine, SplitKludgeBlob, BuildKludgePrefix, BuildKludgeSuffix. Single source of truth for kludge naming, INTL/FMPT/TOPT recognition, and the kludge. forward-compat passthrough. Eliminates the four near-identical parsers MSG/PKT/Squish were carrying; JAM's FTSKLUDGE subfield walking also routes through ParseKludgeLine so its unknown kludges land in the same `kludge.` slot as the others. Bug fix folded in: the parser previously split kludge name from value at the first ':' it found, which broke INTL (the value contains an FTN address with ':' in it). Now picks the earlier of space and colon, which handles both colon-form ("MSGID: foo") and space-form ("INTL ") kludges correctly. (2) INTL / FMPT / TOPT slots in attributes registry FSC-4008 cross-zone routing kludges every netmail tosser carries. Added to JAM/Squish/MSG/PKT capability lists, parsed natively, emitted on Write. Round-trip covered by tests. (3) Unified `kludge.*` namespace for unknown FTSC kludges Squish's `squish.kludge.`, MSG's `msg.kludge.`, and PKT's `pkt.kludge.` all collapse to plain `kludge.`. Consumers find passthrough kludges without switching on format. JAM's numeric `jam.subfield.` stays — those are JAM-specific binary subfields, not FTSC-form kludges. (4) `area` auto-populated from base.AreaTag on Read When the caller passes AAreaTag to MessageBaseOpen (or sets the AreaTag property post-construction), every successful ReadMessage fills msg.Attributes['area'] unless the adapter already populated it from on-disk data (e.g. PKT AREA kludge). Saves echomail consumers from copying AreaTag into every message attribute manually. (5) TMsgAttributes multi-line helpers GetList / SetList / AppendListItem on TMsgAttributes for the multi-instance attributes (seen-by, path, via, trace) that store with #13 between entries. Consumers don't have to roll their own split/join. Plus two PKT polish items from the same feedback round: (6) ma.fmt.pkt.uni.DoWriteMessage now raises EMessageBase explicitly with a pointer to the Native API instead of silently returning False. (7) TPktFile.CreateFromStream / CreateNewToStream constructors accept any TStream (with optional ownership), so unit tests that round-trip via TMemoryStream don't have to tempfile-dance. FStream is now TStream; FOwnsStream gates Free in destructor. TStringDynArray moved from ma.api.pas to ma.types.pas so both the capabilities API and the new attribute helpers can share it. Docs sweep: - docs/attributes-registry.md: intl/fmpt/topt added; unknown-kludge convention documented; multi-line helper section added. - docs/architecture.md: ma.kludge layer surfaced; .uni adapter registration gotcha called out loudly with the recommended uses clause; area auto-pop documented. - docs/API.md: TUniMessage section rewritten for Body+Attributes model (was still pre-0.2); HWM API documented; PKT cheat-sheet notes Native + CreateFromStream; tests/programs list updated. - README.md: Building section flags the .uni gotcha first thing; ma.kludge added to features. tests/test_consumer_round1.pas: 7 new tests covering INTL/FMPT/ TOPT round-trip on JAM/Squish/MSG, area auto-pop, GetList/SetList/ AppendListItem, PKT raise, and TPktFile in-memory stream round-trip. Suite: 47/47 across 10 programs (test_consumer_round1 adds 7). --- README.md | 18 +- docs/API.md | 185 ++++++++++++++---- docs/architecture.md | 64 ++++++- docs/attributes-registry.md | 40 +++- run_tests.sh | 2 + src/formats/ma.fmt.jam.uni.pas | 84 ++++---- src/formats/ma.fmt.msg.uni.pas | 191 ++---------------- src/formats/ma.fmt.pkt.pas | 59 +++++- src/formats/ma.fmt.pkt.uni.pas | 111 ++--------- src/formats/ma.fmt.squish.uni.pas | 148 ++++---------- src/ma.api.pas | 10 +- src/ma.kludge.pas | 297 ++++++++++++++++++++++++++++ src/ma.types.pas | 66 +++++++ tests/test_consumer_round1.pas | 308 ++++++++++++++++++++++++++++++ 14 files changed, 1113 insertions(+), 470 deletions(-) create mode 100644 src/ma.kludge.pas create mode 100644 tests/test_consumer_round1.pas diff --git a/README.md b/README.md index a54639f..01fff7f 100644 --- a/README.md +++ b/README.md @@ -47,10 +47,26 @@ can target a single interface regardless of the underlying format on disk. - `TPacketBatch` worker pool for tossers that need to process many `.pkt` files concurrently while serialising writes per destination base. - Path / filename auto-derivation per format from a base directory plus - optional area tag. + optional area tag (`area` attribute auto-populated on Read). +- **Shared FTSC kludge plumbing** in `ma.kludge` — single source of truth + for kludge-line parse/emit (`ParseKludgeLine`, `SplitKludgeBlob`, + `BuildKludgePrefix/Suffix`). Unknown FTSC kludges round-trip uniformly + as `kludge.` regardless of which backend stored them, so + consumers don't switch on format to find passthrough kludges. ## Building +**Use both the native and `.uni` adapter units in your `uses` clause** — +the `.uni` adapter's `initialization` block is what registers the backend +with the unified-API factory. Forgetting it produces +`EMessageBase: No backend registered for `. + +```pascal +uses + ma.types, ma.events, ma.api, + ma.fmt.jam, ma.fmt.jam.uni; { both — .uni registers } +``` + Native Linux: ```sh diff --git a/docs/API.md b/docs/API.md index c805df7..5e25aa8 100644 --- a/docs/API.md +++ b/docs/API.md @@ -44,7 +44,9 @@ begin if not base.Open then Halt(1); for i := 0 to base.MessageCount - 1 do if base.ReadMessage(i, msg) then - WriteLn(msg.WhoFrom, ' -> ', msg.WhoTo, ': ', msg.Subject); + WriteLn(msg.Attributes.Get('from'), + ' -> ', msg.Attributes.Get('to'), + ': ', msg.Attributes.Get('subject')); finally base.Close; base.Free; @@ -147,31 +149,90 @@ unlinks the `.lck` file, and fires `metBaseClosed`. --- -## TUniMessage +## TUniMessage — two-area model -Single format-agnostic message record. Backends convert between -their native record and this on each read/write. +Single format-agnostic record. **Body holds only the message +text; everything else lives in `Attributes`** as namespaced +key/value pairs. Backends convert between their native record +and this on each read/write. ```pascal TUniMessage = record - MsgNum: longint; { backend-assigned number } - WhoFrom: AnsiString; - WhoTo: AnsiString; - Subject: AnsiString; - DateWritten: TDateTime; - DateReceived: TDateTime; { 0 if not received } - Attr: cardinal; { MSG_ATTR_* bitset, see below } - OrigAddr: TFTNAddress; - DestAddr: TFTNAddress; - Cost: word; - Body: AnsiString; { CR-separated, kludges intact } - AreaTag: AnsiString; { optional echo-area tag } - Board: word; { conference/board; 0 = default } + Body: AnsiString; { only the message text } + Attributes: TMsgAttributes; { everything else, key/value } end; ``` +The full attribute key catalog with per-format support matrix +lives in [`docs/attributes-registry.md`](attributes-registry.md). + +### TMsgAttributes accessors + +```pascal +{ Setters } +procedure SetValue(const K, V: AnsiString); +procedure SetInt(const K: AnsiString; V: longint); +procedure SetInt64(const K: AnsiString; V: int64); +procedure SetBool(const K: AnsiString; V: boolean); +procedure SetDate(const K: AnsiString; V: TDateTime); +procedure SetAddr(const K: AnsiString; const V: TFTNAddress); +procedure SetList(const K: AnsiString; const V: TStringDynArray); +procedure AppendListItem(const K, Item: AnsiString); + +{ Getters } +function Get(const K: AnsiString; + const Def: AnsiString = ''): AnsiString; +function GetInt (const K: AnsiString; Def: longint = 0): longint; +function GetInt64 (const K: AnsiString; Def: int64 = 0): int64; +function GetBool (const K: AnsiString; Def: boolean = false): boolean; +function GetDate (const K: AnsiString; Def: TDateTime = 0): TDateTime; +function GetAddr (const K: AnsiString): TFTNAddress; +function GetList (const K: AnsiString): TStringDynArray; + +{ Inspection } +function Has(const K: AnsiString): boolean; +procedure Remove(const K: AnsiString); +procedure Clear; +function Count: longint; +function KeyAt(I: longint): AnsiString; +function ValueAt(I: longint): AnsiString; +``` + +Common keys — see [`docs/attributes-registry.md`](attributes-registry.md): + +| Key | Type | Meaning | +|---|---|---| +| `msg.num` | int | backend-assigned message number | +| `from` / `to` / `subject` | string | universal headers | +| `date.written` / `date.received` | date | timestamps | +| `addr.orig` / `addr.dest` | ftn | FTN addresses | +| `area` | string | echo area tag (auto-pop from base.AreaTag) | +| `board` | int | multi-board format conference number | +| `attr.*` | bool | private/crash/sent/read/etc. (see registry) | +| `msgid` / `replyid` / `pid` / `flags` | string | FTSC kludges | +| `seen-by` / `path` / `via` | multi | FTS-4 routing kludges (use GetList) | +| `intl` / `fmpt` / `topt` | string | FSC-4008 cross-zone routing | +| `kludge.` | string | unknown FTSC kludge passthrough | + +### Capabilities API + +Each backend declares the canonical list of attribute keys it +understands. Callers query before setting: + +```pascal +function TMessageBase.SupportsAttribute(const Key: AnsiString): boolean; +function TMessageBase.SupportedAttributes: TStringDynArray; + +if base.SupportsAttribute('attr.returnreceipt') then + RenderReceiptCheckbox; +``` + ### Canonical attribute bits (`ma.types`) +The MSG_ATTR_* cardinal constants stay as the internal pivot +between native flag words and the individual `attr.*` boolean +attributes: + ``` MSG_ATTR_PRIVATE $00000001 MSG_ATTR_DELETED $00010000 MSG_ATTR_CRASH $00000002 MSG_ATTR_READ $00020000 @@ -193,6 +254,10 @@ MSG_ATTR_FILE_UPD_REQ $00004000 Bits 0..15 match FTS-0001 exactly; 16+ are for storage-layer flags (deleted/read/echo/etc.) that aren't part of the FTN wire format. +Use `UniAttrBitsToAttributes` / `UniAttrBitsFromAttributes` +helpers in `ma.types` to bridge the bitset to/from individual +`attr.*` boolean attributes. + ### FTN addressing ```pascal @@ -211,14 +276,28 @@ function FTNAddressEqual(const A, B: TFTNAddress): boolean; ```pascal function ReadMessage(Index: longint; var Msg: TUniMessage): boolean; property MessageCount: longint; +property AreaTag: AnsiString; { auto-pop msg.area on Read } +property ActiveUser: AnsiString; { auto-bump HWM on Read } ``` Zero-based index. Returns False on EOF or backend failure. -Message numbers (`Msg.MsgNum`) are backend-assigned and typically -**don't** match the index (most formats keep a gap-tolerant index). -Fires `metMessageRead` on success. +Message numbers come back in `msg.Attributes.GetInt('msg.num')` +and are backend-assigned (typically **don't** match the index; +most formats keep a gap-tolerant index). Fires `metMessageRead` +on success. + +If `AreaTag` is set (either via `MessageBaseOpen`'s `AAreaTag` +parameter or the property setter post-construction), every +successful Read auto-populates `msg.Attributes['area']` with +the tag, unless the adapter already populated it from on-disk +data (e.g. PKT's AREA kludge). + +If `ActiveUser` is set and the backend supports HWM, every +successful Read advances the per-user HWM if `msg.num >` +current HWM (never decrements). See *HWM* below. ```pascal +base.ActiveUser := 'NetReader'; { optional: HWM auto-bump } for i := 0 to base.MessageCount - 1 do if base.ReadMessage(i, msg) then Handle(msg); @@ -232,21 +311,51 @@ for i := 0 to base.MessageCount - 1 do function WriteMessage(var Msg: TUniMessage): boolean; ``` -Appends a new message. Backend assigns `Msg.MsgNum` on success. -Fires `metMessageWritten`. Raises `EMessageBase` in read-only mode. +Appends a new message. Backend assigns `msg.Attributes['msg.num']` +on success. Fires `metMessageWritten`. Raises `EMessageBase` in +read-only mode. PKT raises `EMessageBase` regardless of mode — +write packets via `Native: TPktFile` directly. ```pascal -msg.WhoFrom := 'Sysop'; -msg.WhoTo := 'All'; -msg.Subject := 'Hello'; -msg.DateWritten := Now; -msg.Attr := MSG_ATTR_LOCAL or MSG_ATTR_ECHO; -msg.OrigAddr := MakeFTNAddress(1, 100, 1, 0); -msg.DestAddr := MakeFTNAddress(1, 100, 2, 0); -msg.Body := 'Hello, world' + #13; +msg.Attributes.Clear; +msg.Attributes.SetValue('from', 'Sysop'); +msg.Attributes.SetValue('to', 'All'); +msg.Attributes.SetValue('subject', 'Hello'); +msg.Attributes.SetDate ('date.written', Now); +msg.Attributes.SetBool ('attr.local', true); +msg.Attributes.SetBool ('attr.echo', true); +msg.Attributes.SetAddr ('addr.orig', MakeFTNAddress(1, 100, 1, 0)); +msg.Attributes.SetAddr ('addr.dest', MakeFTNAddress(1, 100, 2, 0)); +msg.Body := 'Hello, world'; base.WriteMessage(msg); ``` +### High-Water Mark (HWM) + +Per-user "last message I scanned" pointer. Native for JAM, +Squish, Hudson, GoldBase; -1 (unsupported) for the others. + +```pascal +function SupportsHWM: boolean; +function GetHWM(const UserName: AnsiString): longint; +procedure SetHWM(const UserName: AnsiString; MsgNum: longint); +procedure MapUser(const UserName: AnsiString; UserId: longint); +property ActiveUser: AnsiString; +property Board: longint; { multi-board context } +``` + +Tossers / scanners register as named users (e.g. `'NetReader'`, +`'Allfix'`, `'FidoMail-Toss'`); each gets its own slot in the +format's native lastread file, so multiple consumers coexist. + +Number-keyed formats (Hudson, GoldBase, EzyCom) need +`MapUser('NetReader', 60001)` (pick `60000+` to avoid colliding +with real BBS users) and `Board := ` before HWM ops; otherwise +return -1. + +See [`docs/architecture.md`](architecture.md) HWM section for +the full coverage map and rationale. + --- ## Updating & deleting @@ -437,7 +546,8 @@ procedure TTosser.OnMsg(const Path: AnsiString; var base: TMessageBase; begin - base := Batch.GetOrCreateBase(mbfJam, '/msg/echo/' + Msg.AreaTag); + base := Batch.GetOrCreateBase(mbfJam, + '/msg/echo/' + Msg.Attributes.Get('area')); if base <> nil then base.WriteMessage(Msg); end; @@ -503,7 +613,7 @@ Native class names: | JAM | dir + basename, no ext | Adapter appends `.JHR/.JDT/.JDX/.JLR` | | Squish | dir + basename, no ext | Adapter appends `.SQD/.SQI/.SQL` | | FTS-1 MSG| directory | Numbered `*.msg` / `*.MSG` (case mixed) | -| FTN PKT | full packet filename | Stream-only; `WriteMessage` not supported through adapter — use `Native` | +| FTN PKT | full packet filename | Stream-only; `WriteMessage` raises `EMessageBase` — use `Native` (`TPktFile`). For in-memory tests, `TPktFile.CreateFromStream` / `CreateNewToStream` accept any `TStream`. | | PCBoard | dir + basename, no ext | Adapter appends `.MSG/.IDX` | | EzyCom | directory + `.Board` | Set `adapter.Board`/`.BBSType` before Open | | Wildcat | WC data dir + `.Conference` | Set `adapter.Conference` before Open | @@ -515,7 +625,14 @@ Native class names: - `docs/architecture.md` — layered design - `docs/ftsc-compliance.md` — spec refs - `docs/format-notes/` — per-format quirks and dependencies +- `docs/attributes-registry.md` — full attribute key catalog + + per-format support matrix - `examples/` — runnable `example_read`, `example_write`, `example_tosser` -- `tests/` — test_read, test_roundtrip, test_lock, test_batch, - test_wildcat, test_write_existing, test_pack +- `tests/` — test_read, test_roundtrip, test_roundtrip_attrs, + test_lock, test_batch, test_wildcat, test_write_existing, + test_pack, test_hwm, test_consumer_round1 +- `ma.kludge` — shared FTSC kludge parsing/emission helpers + (`ParseKludgeLine`, `SplitKludgeBlob`, `BuildKludgePrefix`, + `BuildKludgeSuffix`) for callers that need to handle raw FTSC + body blobs outside an adapter diff --git a/docs/architecture.md b/docs/architecture.md index a88bec9..de5a24c 100644 --- a/docs/architecture.md +++ b/docs/architecture.md @@ -11,18 +11,38 @@ ┌──────────────────────────────────────────────────┐ │ ma.api (TMessageBase, factory, TUniMessage) │ ├──────────────────────────────────────────────────┤ - │ ma.events ma.lock ma.paths │ + │ ma.events ma.lock ma.paths ma.kludge │ │ ma.batch (concurrent tosser helper) │ ├──────────────────────────────────────────────────┤ - │ Format backends — one .pas per format │ - │ ma.fmt.hudson ma.fmt.jam ma.fmt.squish │ - │ ma.fmt.msg ma.fmt.pkt ma.fmt.pcboard │ - │ ma.fmt.ezycom ma.fmt.goldbase ma.fmt.wildcat │ + │ Format backends — two .pas units per format: │ + │ ma.fmt. - native record + I/O class │ + │ ma.fmt..uni - TMessageBase adapter │ + │ ma.fmt.hudson(.uni) ma.fmt.jam(.uni) │ + │ ma.fmt.squish(.uni) ma.fmt.msg(.uni) │ + │ ma.fmt.pkt(.uni) ma.fmt.pcboard(.uni) │ + │ ma.fmt.ezycom(.uni) ma.fmt.goldbase(.uni) │ + │ ma.fmt.wildcat(.uni) │ ├──────────────────────────────────────────────────┤ │ RTL: TFileStream, BaseUnix/Windows for locking │ └──────────────────────────────────────────────────┘ ``` +**Integration gotcha:** to use a backend through the unified +`TMessageBase` API you must include the `.uni` adapter unit in +your `uses` clause, not just the native `ma.fmt.` unit. +The adapter's `initialization` block is what registers the +backend with the factory. + +```pascal +uses + ma.types, ma.events, ma.api, + ma.fmt.jam, ma.fmt.jam.uni; { both — .uni is what registers } +``` + +Forgetting `.uni` produces `EMessageBase: No backend registered +for JAM` at the first `MessageBaseOpen(mbfJam, ...)` call. The +exception message hints at the fix. + ## Polymorphism Every backend descends from `TMessageBase` and implements the abstract @@ -152,6 +172,40 @@ with human-user lastread. Pack rewrites the lastread file in step with the message renumbering. For JAM and Squish this is handled natively. +### `area` auto-population + +When the caller passes an `AAreaTag` to `MessageBaseOpen` (or +sets the `AreaTag` property post-construction), every successful +`ReadMessage` auto-populates `Msg.Attributes['area']` with that +tag — but only if the adapter didn't already populate it from +on-disk data (PKT's AREA kludge, for example). + +This saves echomail consumers from having to copy AreaTag into +every message attribute manually. Multi-format scanners always +get a populated `area` when the area is configured. + +### Shared kludge plumbing — `ma.kludge` + +`ma.kludge` exposes the FTSC-form-kludge parsing/emission helpers +the inline-kludge backends (MSG, PKT) and CtrlInfo-style backend +(Squish) share, plus what JAM's FTSKLUDGE subfield walking uses: + +```pascal +function ParseKludgeLine(const Line: AnsiString; + var A: TMsgAttributes): boolean; +procedure SplitKludgeBlob(const RawBody: AnsiString; + out PlainBody: AnsiString; + var A: TMsgAttributes); +function BuildKludgePrefix(const A: TMsgAttributes): AnsiString; +function BuildKludgeSuffix(const A: TMsgAttributes): AnsiString; +``` + +Consumers that need to parse raw FTSC body blobs (e.g. parity +tests, format converters, debug tools) can call these directly +without reaching into a backend. Single source of truth for +kludge naming, INTL/FMPT/TOPT recognition, and the `kludge.` +forward-compat passthrough. + ### Capabilities API — backend self-description Each backend declares the canonical list of attribute keys it diff --git a/docs/attributes-registry.md b/docs/attributes-registry.md index 5e80baf..bcd30be 100644 --- a/docs/attributes-registry.md +++ b/docs/attributes-registry.md @@ -94,6 +94,38 @@ their lines with `#13`. | `seen-by` | multi-string | FTS-4 | SEEN-BY lines (one node-list per line) | | `path` | multi-string | FTS-4 | PATH lines (one node-list per line) | | `via` | multi-string | FTS-4009 | Via lines (one per relay) | +| `intl` | string | FSC-4008 | INTL kludge: ` ` for cross-zone netmail | +| `fmpt` | string | FSC-4008 | FMPT (origin point number) | +| `topt` | string | FSC-4008 | TOPT (destination point number) | + +### Unknown FTSC kludges + +Any `^A: ` line whose `` is not in the table +above is preserved as `kludge.` regardless of which +backend stored it. Example: `^aXFOO: bar` → `kludge.xfoo` = +`'bar'`. + +This is the universal forward-compat slot for FTSC-form kludges +the library doesn't recognize natively. **All four kludge-aware +backends (JAM, Squish, MSG, PKT) use the same `kludge.*` +namespace** so a consumer can find passthrough kludges without +switching on format. + +JAM's numeric SubField IDs that have no FTSC analogue stay +namespaced as `jam.subfield.` (those aren't FTSC-form +kludges; they're JAM-specific binary subfields). + +### Multi-line attribute helpers + +Attributes that store multiple lines (`seen-by`, `path`, `via`, +`trace`) join their lines with `#13`. Use the typed accessors +on `TMsgAttributes` to avoid manual splitting: + +```pascal +list := msg.Attributes.GetList('seen-by'); // TStringDynArray +msg.Attributes.SetList('path', list); // joins with #13 +msg.Attributes.AppendListItem('seen-by', '3/777'); +``` ## Tier 4 — Format-specific keys @@ -115,8 +147,12 @@ dropped — fine). | `jam.reply1st` | int | First child in reply chain | | `jam.replynext` | int | Next sibling in reply chain | | `jam.attribute2` | int | Reserved JAM attribute2 word | -| `jam.ftskludge` | multi | Passthrough for JAM_FTSKLUDGE subfields | -| `jam.subfield.` | multi | Passthrough for unknown subfield IDs | +| `jam.subfield.` | multi | Passthrough for JAM-numeric subfields with no FTSC kludge analogue | + +(JAM's `JAM_FTSKLUDGE` subfields are parsed through the shared +kludge dispatcher, so their content lands in the canonical slot +— `msgid`, `intl`, etc., or `kludge.` for unknowns — +rather than a JAM-specific bag.) ### Squish diff --git a/run_tests.sh b/run_tests.sh index 7562a73..fb1f198 100755 --- a/run_tests.sh +++ b/run_tests.sh @@ -46,6 +46,7 @@ compile tests/test_wildcat.pas compile tests/test_write_existing.pas compile tests/test_pack.pas compile tests/test_hwm.pas +compile tests/test_consumer_round1.pas echo echo "Running tests..." @@ -58,6 +59,7 @@ run test_wildcat run test_write_existing run test_pack run test_hwm +run test_consumer_round1 echo echo "All tests passed." diff --git a/src/formats/ma.fmt.jam.uni.pas b/src/formats/ma.fmt.jam.uni.pas index 296bde1..5e56f30 100644 --- a/src/formats/ma.fmt.jam.uni.pas +++ b/src/formats/ma.fmt.jam.uni.pas @@ -22,7 +22,7 @@ interface uses Classes, SysUtils, - ma.types, ma.events, ma.api, + ma.types, ma.events, ma.api, ma.kludge, ma.fmt.jam; type @@ -58,40 +58,6 @@ implementation { ---------- Helpers ---------- } -procedure AppendAttr(var A: TMsgAttributes; const Key, Line: AnsiString); -var - cur: AnsiString; -begin - if Line = '' then exit; - cur := A.Get(Key, ''); - if cur = '' then A.SetValue(Key, Line) - else A.SetValue(Key, cur + #13 + Line); -end; - -procedure SplitLines(const S: AnsiString; - out Lines: array of AnsiString; - out Count: longint); -var - i, start, n: longint; -begin - Count := 0; - if S = '' then exit; - n := Length(Lines); - start := 1; - for i := 1 to Length(S) do - if S[i] = #13 then begin - if Count < n then begin - Lines[Count] := Copy(S, start, i - start); - Inc(Count); - end; - start := i + 1; - end; - if (start <= Length(S)) and (Count < n) then begin - Lines[Count] := Copy(S, start, Length(S) - start + 1); - Inc(Count); - end; -end; - procedure AddSubFieldsFromAttr(var SF: TJamSubFields; const A: TMsgAttributes; const AttrKey: AnsiString; @@ -186,7 +152,13 @@ begin JAM_PATH2D: AppendAttr(u.Attributes, 'path', data); JAM_TRACE: AppendAttr(u.Attributes, 'trace', data); JAM_TZUTCINFO: u.Attributes.SetValue('tzutc', data); - JAM_FTSKLUDGE: AppendAttr(u.Attributes, 'jam.ftskludge', data); + JAM_FTSKLUDGE: + { Each FTSKLUDGE entry is an FTSC kludge line in raw form + (without ^A prefix per JAM spec). Dispatch through the + shared parser so it ends up in the canonical slot + (msgid / intl / fmpt / topt / kludge. / etc.). } + if not ParseKludgeLine(#1 + data, u.Attributes) then + AppendAttr(u.Attributes, 'kludge.' + LowerCase(data), ''); else AppendAttr(u.Attributes, 'jam.subfield.' + IntToStr(id), @@ -282,7 +254,24 @@ begin AddSubFieldsFromAttr(j.SubFields, attrs, 'seen-by', JAM_SEENBY2D); AddSubFieldsFromAttr(j.SubFields, attrs, 'path', JAM_PATH2D); AddSubFieldsFromAttr(j.SubFields, attrs, 'trace', JAM_TRACE); - AddSubFieldsFromAttr(j.SubFields, attrs, 'jam.ftskludge', JAM_FTSKLUDGE); + + { FTS-1 cross-zone routing kludges go through JAM_FTSKLUDGE + in raw form (without the leading ^A, per JAM spec). } + if attrs.Get('intl', '') <> '' then begin + idx := Length(j.SubFields); SetLength(j.SubFields, idx + 1); + j.SubFields[idx].ID := JAM_FTSKLUDGE; + j.SubFields[idx].Data := 'INTL ' + attrs.Get('intl', ''); + end; + if attrs.Get('fmpt', '') <> '' then begin + idx := Length(j.SubFields); SetLength(j.SubFields, idx + 1); + j.SubFields[idx].ID := JAM_FTSKLUDGE; + j.SubFields[idx].Data := 'FMPT ' + attrs.Get('fmpt', ''); + end; + if attrs.Get('topt', '') <> '' then begin + idx := Length(j.SubFields); SetLength(j.SubFields, idx + 1); + j.SubFields[idx].ID := JAM_FTSKLUDGE; + j.SubFields[idx].Data := 'TOPT ' + attrs.Get('topt', ''); + end; { Single-instance JAM-specific subfields. } addrStr := attrs.Get('tzutc', ''); @@ -292,8 +281,20 @@ begin j.SubFields[idx].Data := addrStr; end; - { Unknown subfields preserved as jam.subfield. -- emit them - back so a JAM->JAM round-trip keeps unknown SubField IDs intact. } + { Unknown FTSC kludges (kludge.) round-trip via + JAM_FTSKLUDGE so JAM-aware tools see them as kludges, not + JAM-format-specific subfields. } + for i := 0 to attrs.Count - 1 do begin + if Pos('kludge.', attrs.KeyAt(i)) = 1 then begin + idx := Length(j.SubFields); SetLength(j.SubFields, idx + 1); + j.SubFields[idx].ID := JAM_FTSKLUDGE; + j.SubFields[idx].Data := + UpperCase(Copy(attrs.KeyAt(i), 8, Length(attrs.KeyAt(i)))) + ': ' + + attrs.ValueAt(i); + end; + end; + + { Unknown JAM-numeric subfields preserved as jam.subfield.. } for i := 0 to attrs.Count - 1 do begin if Pos('jam.subfield.', attrs.KeyAt(i)) = 1 then AddSubFieldsFromAttr(j.SubFields, attrs, attrs.KeyAt(i), @@ -305,7 +306,7 @@ end; class function TJamMessageBase.ClassSupportedAttributes: TStringDynArray; const - KEYS: array[0..46] of AnsiString = ( + KEYS: array[0..48] of AnsiString = ( { Identity } 'msg.num', { Universal headers } @@ -323,11 +324,12 @@ const { FTSC kludges } 'msgid', 'replyid', 'pid', 'flags', 'seen-by', 'path', 'trace', 'tzutc', + 'intl', 'fmpt', 'topt', { JAM-specific } 'jam.msgidcrc', 'jam.replycrc', 'jam.dateprocessed', 'jam.passwordcrc', 'jam.cost', 'jam.timesread', 'jam.replyto', 'jam.reply1st', - 'jam.replynext', 'jam.attribute2', 'jam.ftskludge' + 'jam.replynext', 'jam.attribute2' ); var i: longint; diff --git a/src/formats/ma.fmt.msg.uni.pas b/src/formats/ma.fmt.msg.uni.pas index 9c75bac..b3661ac 100644 --- a/src/formats/ma.fmt.msg.uni.pas +++ b/src/formats/ma.fmt.msg.uni.pas @@ -21,7 +21,7 @@ interface uses Classes, SysUtils, - ma.types, ma.events, ma.api, + ma.types, ma.events, ma.api, ma.kludge, ma.fmt.msg; type @@ -51,188 +51,18 @@ procedure MsgFromUni(const u: TUniMessage; var m: TMsgMessage); implementation -{ ---------- Body ↔ kludge plumbing ---------- } - -procedure AppendAttr(var A: TMsgAttributes; const Key, Line: AnsiString); -var - cur: AnsiString; -begin - if Line = '' then exit; - cur := A.Get(Key, ''); - if cur = '' then A.SetValue(Key, Line) - else A.SetValue(Key, cur + #13 + Line); -end; - -procedure ParseKludge(const Line: AnsiString; var A: TMsgAttributes); -var - body, name, value, lower: AnsiString; - colon: longint; -begin - if Line = '' then exit; - if Line[1] = #1 then body := Copy(Line, 2, Length(Line) - 1) - else body := Line; - if body = '' then exit; - colon := Pos(':', body); - if colon > 0 then begin - name := Copy(body, 1, colon - 1); - value := Copy(body, colon + 1, Length(body) - colon); - if (Length(value) > 0) and (value[1] = ' ') then - value := Copy(value, 2, Length(value) - 1); - end else begin - name := body; value := ''; - end; - lower := LowerCase(name); - case lower of - 'msgid': A.SetValue('msgid', value); - 'reply': A.SetValue('replyid', value); - 'pid': A.SetValue('pid', value); - 'tid': A.SetValue('tid', value); - 'flags': A.SetValue('flags', value); - 'chrs': A.SetValue('chrs', value); - 'tzutc': A.SetValue('tzutc', value); - 'seen-by': AppendAttr(A, 'seen-by', value); - 'path': AppendAttr(A, 'path', value); - 'via': AppendAttr(A, 'via', value); - else - AppendAttr(A, 'msg.kludge.' + lower, value); - end; -end; - -procedure SplitBodyAndKludges(const RawBody: AnsiString; - out PlainBody: AnsiString; - var A: TMsgAttributes); -var - lines: array of AnsiString; - start, i, n: longint; - line: AnsiString; - isKludge, isTrailControl: boolean; - bodyOut: AnsiString; - upper: AnsiString; -begin - PlainBody := ''; - if RawBody = '' then exit; - - { Split on CR. } - SetLength(lines, 0); - start := 1; - for i := 1 to Length(RawBody) do - if RawBody[i] = #13 then begin - SetLength(lines, Length(lines) + 1); - lines[High(lines)] := Copy(RawBody, start, i - start); - start := i + 1; - end; - if start <= Length(RawBody) then begin - SetLength(lines, Length(lines) + 1); - lines[High(lines)] := Copy(RawBody, start, Length(RawBody) - start + 1); - end; - - n := Length(lines); - bodyOut := ''; - - for i := 0 to n - 1 do begin - line := lines[i]; - isKludge := (Length(line) > 0) and (line[1] = #1); - upper := UpperCase(line); - isTrailControl := - (Pos('SEEN-BY:', upper) = 1) or - (Pos('PATH:', upper) = 1); - if isKludge or isTrailControl then - ParseKludge(line, A) - else begin - if bodyOut = '' then bodyOut := line - else bodyOut := bodyOut + #13 + line; - end; - end; - - PlainBody := bodyOut; -end; - -procedure SplitLines(const S: AnsiString; out Out_: array of AnsiString; - out Count: longint); -var - i, start, max_: longint; -begin - Count := 0; - if S = '' then exit; - max_ := Length(Out_); - start := 1; - for i := 1 to Length(S) do - if S[i] = #13 then begin - if Count < max_ then begin - Out_[Count] := Copy(S, start, i - start); - Inc(Count); - end; - start := i + 1; - end; - if (start <= Length(S)) and (Count < max_) then begin - Out_[Count] := Copy(S, start, Length(S) - start + 1); - Inc(Count); - end; -end; - -procedure AppendKludge(var Body: AnsiString; - const Name, Value: AnsiString; - WithSOH: boolean); -var - line: AnsiString; -begin - if Value = '' then exit; - if WithSOH then line := #1 + Name + ' ' + Value - else line := Name + ' ' + Value; - if Body = '' then Body := line - else Body := Body + #13 + line; -end; - -procedure AppendKludgeLines(var Body: AnsiString; - const Name, Value: AnsiString; - WithSOH: boolean); -var - parts: array[0..255] of AnsiString; - n, i: longint; -begin - if Value = '' then exit; - SplitLines(Value, parts, n); - for i := 0 to n - 1 do - if parts[i] <> '' then AppendKludge(Body, Name, parts[i], WithSOH); -end; - +{ Body assembled from kludge prefix + user text + suffix. } function BuildBody(const u: TUniMessage): AnsiString; -var - attrs: TMsgAttributes; - i: longint; - k, v: AnsiString; begin - attrs := u.Attributes; - Result := ''; - - { Leading ^A kludges. } - AppendKludge(Result, 'MSGID:', attrs.Get('msgid', ''), True); - AppendKludge(Result, 'REPLY:', attrs.Get('replyid', ''), True); - AppendKludge(Result, 'PID:', attrs.Get('pid', ''), True); - AppendKludge(Result, 'TID:', attrs.Get('tid', ''), True); - AppendKludge(Result, 'FLAGS:', attrs.Get('flags', ''), True); - AppendKludge(Result, 'CHRS:', attrs.Get('chrs', ''), True); - AppendKludge(Result, 'TZUTC:', attrs.Get('tzutc', ''), True); - AppendKludgeLines(Result, 'Via', attrs.Get('via', ''), True); - - for i := 0 to attrs.Count - 1 do begin - k := attrs.KeyAt(i); - if Pos('msg.kludge.', k) = 1 then begin - v := attrs.ValueAt(i); - AppendKludgeLines(Result, UpperCase(Copy(k, 12, Length(k))) + ':', - v, True); - end; - end; - - { Body text. } + Result := BuildKludgePrefix(u.Attributes); if u.Body <> '' then begin if Result = '' then Result := u.Body else Result := Result + #13 + u.Body; end; - - { Trailing SEEN-BY/PATH (no SOH per FTSC). } - AppendKludgeLines(Result, 'SEEN-BY:', attrs.Get('seen-by', ''), False); - AppendKludgeLines(Result, 'PATH:', attrs.Get('path', ''), False); + if BuildKludgeSuffix(u.Attributes) <> '' then begin + if Result = '' then Result := BuildKludgeSuffix(u.Attributes) + else Result := Result + #13 + BuildKludgeSuffix(u.Attributes); + end; end; { ---------- Read direction ---------- } @@ -261,7 +91,7 @@ begin if m.NextReply<> 0 then u.Attributes.SetInt('msg.nextreply', m.NextReply); if m.TimesRead<> 0 then u.Attributes.SetInt('msg.timesread', m.TimesRead); - SplitBodyAndKludges(m.Body, plain, u.Attributes); + SplitKludgeBlob(m.Body, plain, u.Attributes); u.Body := plain; end; @@ -298,7 +128,7 @@ end; class function TMsgMessageBase.ClassSupportedAttributes: TStringDynArray; const - KEYS: array[0..28] of AnsiString = ( + KEYS: array[0..31] of AnsiString = ( 'msg.num', 'from', 'to', 'subject', 'addr.orig', 'addr.dest', @@ -309,7 +139,8 @@ const 'attr.killsent', 'attr.local', 'attr.hold', 'attr.filereq', 'attr.returnreceipt', 'attr.isreceipt', 'msgid', 'replyid', 'pid', 'tid', 'flags', 'chrs', - 'tzutc' + 'tzutc', + 'intl', 'fmpt', 'topt' ); var i: longint; diff --git a/src/formats/ma.fmt.pkt.pas b/src/formats/ma.fmt.pkt.pas index db0a1d0..ac84eaa 100644 --- a/src/formats/ma.fmt.pkt.pas +++ b/src/formats/ma.fmt.pkt.pas @@ -100,7 +100,10 @@ type { The main class } TPktFile = class private - FStream: TFileStream; + FStream: TStream; { TFileStream when on-disk; any + TStream when constructed via + CreateFromStream / CreateNewToStream. } + FOwnsStream: boolean; FFileName: string; FHeaderInfo: TPktHeaderInfo; FHeaderWritten: boolean; @@ -115,6 +118,19 @@ type constructor CreateNew(const AFileName: string; const AHeader: TPktHeaderInfo); constructor Open(const AFileName: string); constructor OpenAppend(const AFileName: string); + + { In-memory variants for tests / pipes / TMemoryStream callers. + OwnsStream = true: FStream is freed in destructor (use when + passing a fresh TMemoryStream the caller doesn't keep). + OwnsStream = false: caller retains ownership (typical when + reading from a stream the caller created and will drain + after Destroy). } + constructor CreateFromStream(AStream: TStream; + OwnsStream: boolean = false); + constructor CreateNewToStream(AStream: TStream; + const AHeader: TPktHeaderInfo; + OwnsStream: boolean = false); + destructor Destroy; override; { Header } @@ -238,6 +254,7 @@ begin FWriteMode := true; FHeaderWritten := false; FStream := TFileStream.Create(AFileName, fmCreate); + FOwnsStream := true; WriteHeader(AHeader); end; @@ -251,6 +268,7 @@ begin FWriteMode := false; FHeaderWritten := false; FStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone); + FOwnsStream := true; FillChar(raw, SizeOf(raw), 0); nr := FStream.Read(raw, SizeOf(raw)); @@ -270,6 +288,7 @@ begin FWriteMode := true; FHeaderWritten := true; FStream := TFileStream.Create(AFileName, fmOpenReadWrite or fmShareDenyWrite); + FOwnsStream := true; { Read header } FillChar(raw, SizeOf(raw), 0); @@ -290,9 +309,45 @@ begin FStream.Position := endPos; end; +constructor TPktFile.CreateFromStream(AStream: TStream; + OwnsStream: boolean); +var + raw: PktHeader; + nr: longint; +begin + inherited Create; + FFileName := ''; { in-memory; no path } + FWriteMode := false; + FHeaderWritten := false; + FStream := AStream; + FOwnsStream := OwnsStream; + + FStream.Position := 0; + FillChar(raw, SizeOf(raw), 0); + nr := FStream.Read(raw, SizeOf(raw)); + if nr = SizeOf(raw) then + FHeaderInfo := ParseHeader(raw); +end; + +constructor TPktFile.CreateNewToStream(AStream: TStream; + const AHeader: TPktHeaderInfo; + OwnsStream: boolean); +begin + inherited Create; + FFileName := ''; + FWriteMode := true; + FHeaderWritten := false; + FStream := AStream; + FOwnsStream := OwnsStream; + FStream.Position := 0; + FStream.Size := 0; { fresh slate } + WriteHeader(AHeader); +end; + destructor TPktFile.Destroy; begin - FStream.Free; + if FOwnsStream then FStream.Free; + FStream := nil; inherited Destroy; end; diff --git a/src/formats/ma.fmt.pkt.uni.pas b/src/formats/ma.fmt.pkt.uni.pas index b26aa99..c55fc53 100644 --- a/src/formats/ma.fmt.pkt.uni.pas +++ b/src/formats/ma.fmt.pkt.uni.pas @@ -21,7 +21,7 @@ interface uses Classes, SysUtils, - ma.types, ma.events, ma.api, + ma.types, ma.events, ma.api, ma.kludge, ma.fmt.pkt; type @@ -50,95 +50,6 @@ procedure PktToUni(const p: TPktMessage; var u: TUniMessage); implementation -{ ---------- Body ↔ kludge plumbing (same shape as MSG) ---------- } - -procedure AppendAttr(var A: TMsgAttributes; const Key, Line: AnsiString); -var - cur: AnsiString; -begin - if Line = '' then exit; - cur := A.Get(Key, ''); - if cur = '' then A.SetValue(Key, Line) - else A.SetValue(Key, cur + #13 + Line); -end; - -procedure ParseKludge(const Line: AnsiString; var A: TMsgAttributes); -var - body, name, value, lower: AnsiString; - colon: longint; -begin - if Line = '' then exit; - if Line[1] = #1 then body := Copy(Line, 2, Length(Line) - 1) - else body := Line; - if body = '' then exit; - colon := Pos(':', body); - if colon > 0 then begin - name := Copy(body, 1, colon - 1); - value := Copy(body, colon + 1, Length(body) - colon); - if (Length(value) > 0) and (value[1] = ' ') then - value := Copy(value, 2, Length(value) - 1); - end else begin - name := body; value := ''; - end; - lower := LowerCase(name); - case lower of - 'msgid': A.SetValue('msgid', value); - 'reply': A.SetValue('replyid', value); - 'pid': A.SetValue('pid', value); - 'tid': A.SetValue('tid', value); - 'flags': A.SetValue('flags', value); - 'chrs': A.SetValue('chrs', value); - 'tzutc': A.SetValue('tzutc', value); - 'seen-by': AppendAttr(A, 'seen-by', value); - 'path': AppendAttr(A, 'path', value); - 'via': AppendAttr(A, 'via', value); - else - AppendAttr(A, 'pkt.kludge.' + lower, value); - end; -end; - -procedure SplitBodyAndKludges(const RawBody: AnsiString; - out PlainBody: AnsiString; - var A: TMsgAttributes); -var - lines: array of AnsiString; - start, i, n: longint; - line, upper, bodyOut: AnsiString; - isKludge, isTrailControl: boolean; -begin - PlainBody := ''; - if RawBody = '' then exit; - SetLength(lines, 0); - start := 1; - for i := 1 to Length(RawBody) do - if RawBody[i] = #13 then begin - SetLength(lines, Length(lines) + 1); - lines[High(lines)] := Copy(RawBody, start, i - start); - start := i + 1; - end; - if start <= Length(RawBody) then begin - SetLength(lines, Length(lines) + 1); - lines[High(lines)] := Copy(RawBody, start, Length(RawBody) - start + 1); - end; - n := Length(lines); - bodyOut := ''; - for i := 0 to n - 1 do begin - line := lines[i]; - isKludge := (Length(line) > 0) and (line[1] = #1); - upper := UpperCase(line); - isTrailControl := - (Pos('SEEN-BY:', upper) = 1) or - (Pos('PATH:', upper) = 1); - if isKludge or isTrailControl then - ParseKludge(line, A) - else begin - if bodyOut = '' then bodyOut := line - else bodyOut := bodyOut + #13 + line; - end; - end; - PlainBody := bodyOut; -end; - { ---------- Read direction ---------- } procedure PktToUni(const p: TPktMessage; var u: TUniMessage); @@ -162,7 +73,7 @@ begin if p.Cost <> 0 then u.Attributes.SetInt('pkt.cost', p.Cost); - SplitBodyAndKludges(p.Body, plain, u.Attributes); + SplitKludgeBlob(p.Body, plain, u.Attributes); u.Body := plain; end; @@ -170,7 +81,7 @@ end; class function TPktMessageBase.ClassSupportedAttributes: TStringDynArray; const - KEYS: array[0..27] of AnsiString = ( + KEYS: array[0..30] of AnsiString = ( 'msg.num', 'from', 'to', 'subject', 'addr.orig', 'addr.dest', @@ -180,7 +91,8 @@ const 'attr.fileattach', 'attr.intransit', 'attr.orphan', 'attr.killsent', 'attr.local', 'attr.hold', 'attr.filereq', 'attr.returnreceipt', 'attr.isreceipt', - 'msgid', 'replyid', 'pid', 'tid', 'flags', 'chrs' + 'msgid', 'replyid', 'pid', 'tid', 'flags', 'chrs', + 'intl', 'fmpt', 'topt' ); var i: longint; @@ -315,10 +227,15 @@ end; function TPktMessageBase.DoWriteMessage(var Msg: TUniMessage): boolean; begin - { Append-write would require an OpenAppend mode and a writable - packet. Out of scope for the simple adapter; tossers should - use the native TPktFile directly via Native. } - Result := False; + { PKT through the unified API is read-only. Append-write would + need an OpenAppend mode + per-message PktFromUni emission; + use TPktFile directly via Native for now. Raise explicitly + so callers don't waste a debug cycle on a silent False. } + raise EMessageBase.Create( + 'PKT is read-only through TMessageBase; ' + + 'use the Native property (TPktFile) for writes ' + + '(see ma.fmt.pkt for the full append API).'); + Result := False; { unreachable; satisfies the compiler } end; function CreatePktBase(const APath: AnsiString; diff --git a/src/formats/ma.fmt.squish.uni.pas b/src/formats/ma.fmt.squish.uni.pas index e60911d..54b57dd 100644 --- a/src/formats/ma.fmt.squish.uni.pas +++ b/src/formats/ma.fmt.squish.uni.pas @@ -16,7 +16,7 @@ interface uses Classes, SysUtils, - ma.types, ma.events, ma.api, + ma.types, ma.events, ma.api, ma.kludge, ma.fmt.squish, ma.fmt.jam; { for TJamBase.CalcUserCRC -- shared CRC32 algorithm } @@ -52,97 +52,37 @@ implementation { ---------- CtrlInfo helpers ---------- } -procedure AppendAttr(var A: TMsgAttributes; const Key, Line: AnsiString); -var - cur: AnsiString; -begin - if Line = '' then exit; - cur := A.Get(Key, ''); - if cur = '' then A.SetValue(Key, Line) - else A.SetValue(Key, cur + #13 + Line); -end; - -procedure ParseCtrlInfoLine(const Line: AnsiString; var A: TMsgAttributes); -var - body, name, value: AnsiString; - colon: longint; - lower: AnsiString; -begin - if Line = '' then exit; - { Strip leading ^A (SOH). } - if Line[1] = #1 then body := Copy(Line, 2, Length(Line) - 1) - else body := Line; - if body = '' then exit; - colon := Pos(':', body); - if colon > 0 then begin - name := Copy(body, 1, colon - 1); - value := Copy(body, colon + 1, Length(body) - colon); - if (Length(value) > 0) and (value[1] = ' ') then - value := Copy(value, 2, Length(value) - 1); - end else begin - name := body; - value := ''; - end; - lower := LowerCase(name); - case lower of - 'msgid': A.SetValue('msgid', value); - 'reply': A.SetValue('replyid', value); - 'pid': A.SetValue('pid', value); - 'tid': A.SetValue('tid', value); - 'flags': A.SetValue('flags', value); - 'chrs': A.SetValue('chrs', value); - 'tzutc': A.SetValue('tzutc', value); - 'seen-by': AppendAttr(A, 'seen-by', value); - 'path': AppendAttr(A, 'path', value); - 'via': AppendAttr(A, 'via', value); - else - AppendAttr(A, 'squish.kludge.' + lower, value); - end; -end; - +{ Squish CtrlInfo is NUL-or-CR separated kludge lines. We + normalize NUL to CR and reuse ma.kludge's universal + SplitKludgeBlob; the resulting body fragment (which should + always be empty for CtrlInfo content) is discarded. } procedure ParseCtrlInfo(const Ctrl: AnsiString; var A: TMsgAttributes); var - i, start, n: longint; - line: AnsiString; + norm: AnsiString; + i: longint; + scratch: AnsiString; begin if Ctrl = '' then exit; - n := Length(Ctrl); - start := 1; - for i := 1 to n do - if (Ctrl[i] = #0) or (Ctrl[i] = #13) then begin - line := Copy(Ctrl, start, i - start); - ParseCtrlInfoLine(line, A); - start := i + 1; - end; - if start <= n then - ParseCtrlInfoLine(Copy(Ctrl, start, n - start + 1), A); + SetLength(norm, Length(Ctrl)); + for i := 1 to Length(Ctrl) do + if Ctrl[i] = #0 then norm[i] := #13 + else norm[i] := Ctrl[i]; + SplitKludgeBlob(norm, scratch, A); end; -procedure SplitLines(const S: AnsiString; out Out_: array of AnsiString; - out Count: longint); -var - i, start, max_: longint; +{ Build NUL-separated CtrlInfo from the canonical attribute set, + re-emitting INTL/FMPT/TOPT/MSGID/REPLY/PID/TID/FLAGS/CHRS/TZUTC, + multi-line SEEN-BY/PATH/Via, plus any kludge. passthrough. } +procedure AppendCtrlSingle(var Ctrl: AnsiString; + const Name, Value: AnsiString); begin - Count := 0; - if S = '' then exit; - max_ := Length(Out_); - start := 1; - for i := 1 to Length(S) do - if S[i] = #13 then begin - if Count < max_ then begin - Out_[Count] := Copy(S, start, i - start); - Inc(Count); - end; - start := i + 1; - end; - if (start <= Length(S)) and (Count < max_) then begin - Out_[Count] := Copy(S, start, Length(S) - start + 1); - Inc(Count); - end; + if Value = '' then exit; + if Ctrl <> '' then Ctrl := Ctrl + #0; + Ctrl := Ctrl + #1 + Name + ' ' + Value; end; -procedure AppendKludgeLines(var Ctrl: AnsiString; - const Name, Value: AnsiString); +procedure AppendCtrlLines(var Ctrl: AnsiString; + const Name, Value: AnsiString); var parts: array[0..255] of AnsiString; n, i: longint; @@ -156,14 +96,6 @@ begin end; end; -procedure AppendKludgeSingle(var Ctrl: AnsiString; - const Name, Value: AnsiString); -begin - if Value = '' then exit; - if Ctrl <> '' then Ctrl := Ctrl + #0; - Ctrl := Ctrl + #1 + Name + ' ' + Value; -end; - function BuildCtrlInfo(const A: TMsgAttributes): AnsiString; var attrs: TMsgAttributes; @@ -171,22 +103,25 @@ var k, v: AnsiString; begin Result := ''; - attrs := A; { record copy for read-only walk } - AppendKludgeSingle(Result, 'MSGID:', attrs.Get('msgid', '')); - AppendKludgeSingle(Result, 'REPLY:', attrs.Get('replyid', '')); - AppendKludgeSingle(Result, 'PID:', attrs.Get('pid', '')); - AppendKludgeSingle(Result, 'TID:', attrs.Get('tid', '')); - AppendKludgeSingle(Result, 'FLAGS:', attrs.Get('flags', '')); - AppendKludgeSingle(Result, 'CHRS:', attrs.Get('chrs', '')); - AppendKludgeSingle(Result, 'TZUTC:', attrs.Get('tzutc', '')); - AppendKludgeLines(Result, 'SEEN-BY:', attrs.Get('seen-by', '')); - AppendKludgeLines(Result, 'PATH:', attrs.Get('path', '')); - AppendKludgeLines(Result, 'Via', attrs.Get('via', '')); + attrs := A; + AppendCtrlSingle(Result, 'INTL', attrs.Get('intl', '')); + AppendCtrlSingle(Result, 'FMPT', attrs.Get('fmpt', '')); + AppendCtrlSingle(Result, 'TOPT', attrs.Get('topt', '')); + AppendCtrlSingle(Result, 'MSGID:', attrs.Get('msgid', '')); + AppendCtrlSingle(Result, 'REPLY:', attrs.Get('replyid', '')); + AppendCtrlSingle(Result, 'PID:', attrs.Get('pid', '')); + AppendCtrlSingle(Result, 'TID:', attrs.Get('tid', '')); + AppendCtrlSingle(Result, 'FLAGS:', attrs.Get('flags', '')); + AppendCtrlSingle(Result, 'CHRS:', attrs.Get('chrs', '')); + AppendCtrlSingle(Result, 'TZUTC:', attrs.Get('tzutc', '')); + AppendCtrlLines(Result, 'SEEN-BY:', attrs.Get('seen-by', '')); + AppendCtrlLines(Result, 'PATH:', attrs.Get('path', '')); + AppendCtrlLines(Result, 'Via', attrs.Get('via', '')); for i := 0 to attrs.Count - 1 do begin k := attrs.KeyAt(i); - if Pos('squish.kludge.', k) = 1 then begin + if Pos('kludge.', k) = 1 then begin v := attrs.ValueAt(i); - AppendKludgeLines(Result, UpperCase(Copy(k, 15, Length(k))) + ':', v); + AppendCtrlLines(Result, UpperCase(Copy(k, 8, Length(k))) + ':', v); end; end; end; @@ -258,7 +193,7 @@ end; class function TSquishMessageBase.ClassSupportedAttributes: TStringDynArray; const - KEYS: array[0..32] of AnsiString = ( + KEYS: array[0..35] of AnsiString = ( 'msg.num', 'from', 'to', 'subject', 'addr.orig', 'addr.dest', @@ -270,9 +205,8 @@ const 'attr.returnreceipt', 'attr.isreceipt', 'attr.auditreq', 'attr.fileupdreq', 'attr.deleted', 'msgid', 'replyid', 'pid', 'tid', 'flags', 'chrs', 'tzutc', + 'intl', 'fmpt', 'topt', 'seen-by' - { 'path' and 'via' too -- adding next; index needs to be in - sync with array bounds. } ); var i: longint; diff --git a/src/ma.api.pas b/src/ma.api.pas index 1514135..678b96d 100644 --- a/src/ma.api.pas +++ b/src/ma.api.pas @@ -23,7 +23,8 @@ type EMessageBase = class(Exception); - TStringDynArray = array of AnsiString; + { TStringDynArray comes from ma.types; re-exported here as + well so existing callers that only use ma.api keep working. } { TMessageBase - abstract root for every backend. Descendants implement the DoXxx virtuals; the public methods @@ -325,6 +326,13 @@ begin end; if Result then begin FireEvent(metMessageRead, '', Index); + { Auto-populate `area` from base.AreaTag if the caller passed + it via MessageBaseOpen. Most echomail-format on-disk records + don't carry the area tag; the caller knows it from area + configuration. Adapters that DO carry it (e.g. PKT's AREA + kludge) override by populating Attributes themselves. } + if (FAreaTag <> '') and (not Msg.Attributes.Has('area')) then + Msg.Attributes.SetValue('area', FAreaTag); { Auto-bump HWM if ActiveUser is set and the message we just read has a higher msg.num than the user's current HWM. } if (FActiveUser <> '') and (not FReadOnly) and DoSupportsHWM then begin diff --git a/src/ma.kludge.pas b/src/ma.kludge.pas new file mode 100644 index 0000000..b16e74d --- /dev/null +++ b/src/ma.kludge.pas @@ -0,0 +1,297 @@ +{ ma.kludge - shared FTS-1 kludge parsing + emission. + + Three of the format backends (FTS-1 *.MSG, FTN PKT, Squish) keep + kludge lines inline in body or in a kludge string. This unit + centralises: + + - SplitKludgeBlob: walk a CR-separated body, dispatch ^A... + kludge lines and trailing SEEN-BY:/PATH: lines into the + canonical attribute keys, return what's left as plain user + text. + - ParseKludgeLine: dispatch a single line. + - BuildKludgePrefix / BuildKludgeSuffix: emit known kludges + back into FTSC wire form for adapters that need to + reassemble inline bodies. + + Ensures every backend uses the same naming for unknown kludges + (`kludge.`, e.g. `^aFOO: bar` -> attributes['kludge.foo'] + := 'bar'), the same INTL/FMPT/TOPT recognition, and the same + multi-line collapse for SEEN-BY/PATH/Via/TRACE. } + +unit ma.kludge; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +interface + +uses + Classes, SysUtils, + ma.types; + +{ Append a single line to a multi-line attribute, joining with + #13. No-op when Line is empty. } +procedure AppendAttr(var A: TMsgAttributes; + const Key, Line: AnsiString); + +{ Parse a single FTSC-form line and dispatch it into the + appropriate attribute slot. Recognised: + - ^A-prefixed lines: standard FTSC kludges + (msgid, reply, pid, tid, flags, chrs, tzutc, intl, fmpt, topt, + via, seen-by, path) + - non-^A lines starting with "SEEN-BY:" or "PATH:": trailing + control lines (FTS-4) + Anything else with the ^A-form `^a(:|space)` is + parsed as an unknown kludge and stored under `kludge.`. + Lines with no recognisable form are ignored. + + Returns True if the line was consumed as a kludge (caller drops + it from the body); False if the line is body text. } +function ParseKludgeLine(const Line: AnsiString; + var A: TMsgAttributes): boolean; + +{ Walk a CR-separated body, route every kludge line into A, + return what remains as PlainBody. Body comes back without + any kludge or trailing control line -- it's pure user text. } +procedure SplitKludgeBlob(const RawBody: AnsiString; + out PlainBody: AnsiString; + var A: TMsgAttributes); + +{ Split a multi-line attribute value (#13-separated) back into + individual lines. Caller-provided buffer; Count returns how + many lines were emitted. } +procedure SplitLines(const S: AnsiString; + out Lines: array of AnsiString; + out Count: longint); + +{ Append `^A ` (or just " " if + WithSOH=False) to Body, prefixed by #13 if Body is non-empty. } +procedure AppendKludge(var Body: AnsiString; + const Name, Value: AnsiString; + WithSOH: boolean); + +{ Append one kludge line per CR-separated value entry. } +procedure AppendKludgeLines(var Body: AnsiString; + const Name, Value: AnsiString; + WithSOH: boolean); + +{ Build the kludge prefix (lines that go BEFORE body text in + FTSC inline-kludge formats). Uses the canonical attribute + set: msgid, reply, pid, tid, flags, chrs, tzutc, intl, fmpt, + topt, via, plus any kludge. attributes (for forward- + compat passthrough of unknown kludges). } +function BuildKludgePrefix(const A: TMsgAttributes): AnsiString; + +{ Build the kludge suffix (SEEN-BY: and PATH: lines that go + AFTER body text in FTSC inline-kludge formats; no SOH per + FTS-4). } +function BuildKludgeSuffix(const A: TMsgAttributes): AnsiString; + +implementation + +procedure AppendAttr(var A: TMsgAttributes; + const Key, Line: AnsiString); +var + cur: AnsiString; +begin + if Line = '' then exit; + cur := A.Get(Key, ''); + if cur = '' then A.SetValue(Key, Line) + else A.SetValue(Key, cur + #13 + Line); +end; + +function ParseKludgeLine(const Line: AnsiString; + var A: TMsgAttributes): boolean; +var + body, name, value, lower, upperLine: AnsiString; + splitPos, colonPos, spacePos: longint; + isKludge, isTrailControl: boolean; +begin + Result := False; + if Line = '' then exit; + isKludge := Line[1] = #1; + upperLine := UpperCase(Line); + isTrailControl := (Pos('SEEN-BY:', upperLine) = 1) or + (Pos('PATH:', upperLine) = 1); + if not (isKludge or isTrailControl) then exit; + + if isKludge then body := Copy(Line, 2, Length(Line) - 1) + else body := Line; + if body = '' then begin Result := True; exit; end; + + { Kludge name terminates at the FIRST of space or colon. + Values often contain ':' (FTN addresses, dates) so we can't + just look for a colon. } + colonPos := Pos(':', body); + spacePos := Pos(' ', body); + if (colonPos > 0) and ((spacePos = 0) or (colonPos < spacePos)) then + splitPos := colonPos + else if spacePos > 0 then + splitPos := spacePos + else + splitPos := 0; + + if splitPos > 0 then begin + name := Copy(body, 1, splitPos - 1); + value := Copy(body, splitPos + 1, Length(body) - splitPos); + { Strip a single leading colon-separator-space when name was + colon-terminated (e.g. "MSGID: foo" -> value "foo"). } + if (body[splitPos] = ':') and (Length(value) > 0) and (value[1] = ' ') then + value := Copy(value, 2, Length(value) - 1); + end else begin + name := body; + value := ''; + end; + lower := LowerCase(name); + + case lower of + 'msgid': A.SetValue('msgid', value); + 'reply': A.SetValue('replyid', value); + 'pid': A.SetValue('pid', value); + 'tid': A.SetValue('tid', value); + 'flags': A.SetValue('flags', value); + 'chrs': A.SetValue('chrs', value); + 'tzutc': A.SetValue('tzutc', value); + 'intl': A.SetValue('intl', value); + 'fmpt': A.SetValue('fmpt', value); + 'topt': A.SetValue('topt', value); + 'seen-by': AppendAttr(A, 'seen-by', value); + 'path': AppendAttr(A, 'path', value); + 'via': AppendAttr(A, 'via', value); + else + AppendAttr(A, 'kludge.' + lower, value); + end; + Result := True; +end; + +procedure SplitKludgeBlob(const RawBody: AnsiString; + out PlainBody: AnsiString; + var A: TMsgAttributes); +var + i, start, n: longint; + line, bodyOut: AnsiString; + lines: array of AnsiString; +begin + PlainBody := ''; + if RawBody = '' then exit; + + SetLength(lines, 0); + start := 1; + for i := 1 to Length(RawBody) do + if RawBody[i] = #13 then begin + SetLength(lines, Length(lines) + 1); + lines[High(lines)] := Copy(RawBody, start, i - start); + start := i + 1; + end; + if start <= Length(RawBody) then begin + SetLength(lines, Length(lines) + 1); + lines[High(lines)] := Copy(RawBody, start, Length(RawBody) - start + 1); + end; + + n := Length(lines); + bodyOut := ''; + for i := 0 to n - 1 do begin + line := lines[i]; + if not ParseKludgeLine(line, A) then begin + if bodyOut = '' then bodyOut := line + else bodyOut := bodyOut + #13 + line; + end; + end; + PlainBody := bodyOut; +end; + +procedure SplitLines(const S: AnsiString; + out Lines: array of AnsiString; + out Count: longint); +var + i, start, max_: longint; +begin + Count := 0; + if S = '' then exit; + max_ := Length(Lines); + start := 1; + for i := 1 to Length(S) do + if S[i] = #13 then begin + if Count < max_ then begin + Lines[Count] := Copy(S, start, i - start); + Inc(Count); + end; + start := i + 1; + end; + if (start <= Length(S)) and (Count < max_) then begin + Lines[Count] := Copy(S, start, Length(S) - start + 1); + Inc(Count); + end; +end; + +procedure AppendKludge(var Body: AnsiString; + const Name, Value: AnsiString; + WithSOH: boolean); +var + line: AnsiString; +begin + if Value = '' then exit; + if WithSOH then line := #1 + Name + ' ' + Value + else line := Name + ' ' + Value; + if Body = '' then Body := line + else Body := Body + #13 + line; +end; + +procedure AppendKludgeLines(var Body: AnsiString; + const Name, Value: AnsiString; + WithSOH: boolean); +var + parts: array[0..255] of AnsiString; + n, i: longint; +begin + if Value = '' then exit; + SplitLines(Value, parts, n); + for i := 0 to n - 1 do + if parts[i] <> '' then + AppendKludge(Body, Name, parts[i], WithSOH); +end; + +function BuildKludgePrefix(const A: TMsgAttributes): AnsiString; +var + attrs: TMsgAttributes; + i: longint; + k, v: AnsiString; +begin + attrs := A; + Result := ''; + AppendKludge(Result, 'INTL', attrs.Get('intl', ''), True); + AppendKludge(Result, 'FMPT', attrs.Get('fmpt', ''), True); + AppendKludge(Result, 'TOPT', attrs.Get('topt', ''), True); + AppendKludge(Result, 'MSGID:', attrs.Get('msgid', ''), True); + AppendKludge(Result, 'REPLY:', attrs.Get('replyid', ''), True); + AppendKludge(Result, 'PID:', attrs.Get('pid', ''), True); + AppendKludge(Result, 'TID:', attrs.Get('tid', ''), True); + AppendKludge(Result, 'FLAGS:', attrs.Get('flags', ''), True); + AppendKludge(Result, 'CHRS:', attrs.Get('chrs', ''), True); + AppendKludge(Result, 'TZUTC:', attrs.Get('tzutc', ''), True); + AppendKludgeLines(Result, 'Via', attrs.Get('via', ''), True); + + { Forward-compat passthrough of unknown FTSC-form kludges. } + for i := 0 to attrs.Count - 1 do begin + k := attrs.KeyAt(i); + if Pos('kludge.', k) = 1 then begin + v := attrs.ValueAt(i); + AppendKludgeLines(Result, + UpperCase(Copy(k, 8, Length(k))) + ':', + v, True); + end; + end; +end; + +function BuildKludgeSuffix(const A: TMsgAttributes): AnsiString; +var + attrs: TMsgAttributes; +begin + attrs := A; + Result := ''; + { Trailing FTSC-4 control lines (no ^A prefix per spec). } + AppendKludgeLines(Result, 'SEEN-BY:', attrs.Get('seen-by', ''), False); + AppendKludgeLines(Result, 'PATH:', attrs.Get('path', ''), False); +end; + +end. diff --git a/src/ma.types.pas b/src/ma.types.pas index 75fd308..4d5a23d 100644 --- a/src/ma.types.pas +++ b/src/ma.types.pas @@ -15,6 +15,10 @@ uses Classes, SysUtils; type + { Shared dynamic-string-array type used by capability lists, + multi-line attribute helpers, etc. } + TStringDynArray = array of AnsiString; + { ---------- FTN addressing ---------- } TFTNAddress = record @@ -76,6 +80,15 @@ type function GetDate(const K: AnsiString; Def: TDateTime = 0): TDateTime; function GetAddr(const K: AnsiString): TFTNAddress; + + { Multi-line attribute helpers -- multi-instance keys + (seen-by, path, via, trace) are stored as a single + string with #13 between entries. GetList splits on #13 + and returns the lines; SetList joins. Empty entries are + dropped on both ends. } + function GetList(const K: AnsiString): TStringDynArray; + procedure SetList(const K: AnsiString; const V: TStringDynArray); + procedure AppendListItem(const K, Item: AnsiString); end; { ---------- Canonical message ---------- } @@ -964,6 +977,59 @@ begin Result := MakeFTNAddress(0, 0, 0, 0); end; +function TMsgAttributes.GetList(const K: AnsiString): TStringDynArray; +var + s: AnsiString; + i, start, n, lineCount: longint; +begin + SetLength(Result, 0); + s := Get(K, ''); + if s = '' then exit; + lineCount := 1; + for i := 1 to Length(s) do + if s[i] = #13 then Inc(lineCount); + SetLength(Result, lineCount); + n := 0; + start := 1; + for i := 1 to Length(s) do + if s[i] = #13 then begin + Result[n] := Copy(s, start, i - start); + Inc(n); + start := i + 1; + end; + if start <= Length(s) then begin + Result[n] := Copy(s, start, Length(s) - start + 1); + Inc(n); + end; + SetLength(Result, n); +end; + +procedure TMsgAttributes.SetList(const K: AnsiString; + const V: TStringDynArray); +var + i: longint; + joined: AnsiString; +begin + joined := ''; + for i := 0 to High(V) do begin + if V[i] = '' then continue; + if joined = '' then joined := V[i] + else joined := joined + #13 + V[i]; + end; + if joined = '' then Remove(K) + else SetValue(K, joined); +end; + +procedure TMsgAttributes.AppendListItem(const K, Item: AnsiString); +var + cur: AnsiString; +begin + if Item = '' then exit; + cur := Get(K, ''); + if cur = '' then SetValue(K, Item) + else SetValue(K, cur + #13 + Item); +end; + { ---------- Canonical attribute-bit <-> Attributes ---------- } procedure UniAttrBitsToAttributes(Attr: cardinal; diff --git a/tests/test_consumer_round1.pas b/tests/test_consumer_round1.pas new file mode 100644 index 0000000..acfa679 --- /dev/null +++ b/tests/test_consumer_round1.pas @@ -0,0 +1,308 @@ +{ + 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.` namespace -- unknown FTSC kludges + land under kludge. 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). + 5. ma.fmt.pkt.uni DoWriteMessage raises EMessageBase explicitly + instead of silently returning False. + 6. TPktFile.CreateFromStream / CreateNewToStream -- in-memory + packet round-trip via TMemoryStream (for unit-test suites + that don't want to tempfile-dance). +} + +program test_consumer_round1; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +uses + Classes, SysUtils, + testutil, + ma.types, ma.events, ma.api, ma.kludge, + 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; + +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; + +procedure TestPktWriteRaisesExplicitly; +var + base: TMessageBase; + msg: TUniMessage; + raised: boolean; +begin + TestBegin('PKT through TMessageBase: WriteMessage raises EMessageBase'); + ForceDirectories(SCRATCH + '/pkt'); + CleanDir(SCRATCH + '/pkt'); + { Need an existing packet so Open succeeds. Build one via the + Native API. } + with TPktFile.CreateNew(SCRATCH + '/pkt/in.pkt', + TPktFile.BuildHeaderInfo(1,1,1,0, 1,1,2,0, '')) do + try + WriteTerminator; + finally + Free; + end; + + base := MessageBaseOpen(mbfPkt, SCRATCH + '/pkt/in.pkt', momReadWrite); + try + AssertTrue('Open', base.Open); + msg.Attributes.Clear; + msg.Body := 'unused'; + raised := False; + try + base.WriteMessage(msg); + except + on E: EMessageBase do raised := True; + end; + AssertTrue('WriteMessage raised EMessageBase', raised); + finally + base.Close; + base.Free; + end; + TestOK; +end; + +procedure TestPktCreateFromStream; +var + ms: TMemoryStream; + pkt: TPktFile; + hdr: TPktHeaderInfo; + m: TPktMessage; + reread: TPktFile; + m2: TPktMessage; +begin + TestBegin('TPktFile.CreateNewToStream + CreateFromStream round-trip'); + ms := TMemoryStream.Create; + try + hdr := TPktFile.BuildHeaderInfo(1,1,1,0, 1,1,2,0, ''); + pkt := TPktFile.CreateNewToStream(ms, hdr, false); + try + FillChar(m, SizeOf(m), 0); + m.OrigNode := 1; m.OrigNet := 1; + m.DestNode := 2; m.DestNet := 1; + m.WhoFrom := 'Stream'; m.WhoTo := 'All'; m.Subject := 'mem-pkt'; + m.DateTime := '01 Apr 26 12:00:00'; + m.Body := 'memory stream test'#13; + pkt.WriteMessage(m); + pkt.WriteTerminator; + finally + pkt.Free; + end; + + AssertTrue('Stream has bytes after write', ms.Size > 0); + + { Re-read the same stream into a fresh TPktFile. } + ms.Position := 0; + reread := TPktFile.CreateFromStream(ms, false); + try + AssertTrue('CreateFromStream succeeded', reread <> nil); + AssertTrue('ReadMessage', reread.ReadMessage(m2)); + AssertEquals('round-trip from', 'Stream', m2.WhoFrom); + AssertEquals('round-trip subject', 'mem-pkt', m2.Subject); + finally + reread.Free; + end; + finally + ms.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; + TestPktWriteRaisesExplicitly; + TestPktCreateFromStream; + + Halt(TestsSummary); +end.