From 3bc4cb7bec0cd9a5cee727fa73f8f199b619a450 Mon Sep 17 00:00:00 2001 From: Ken Johnson Date: Tue, 14 Apr 2026 14:34:50 -0700 Subject: [PATCH] Add ma.api: TMessageBase abstract class, factory, format autodetect --- build.sh | 1 + docs/format-notes/dependencies.md | 15 ++ src/ma.api.pas | 419 ++++++++++++++++++++++++++++++ 3 files changed, 435 insertions(+) create mode 100644 src/ma.api.pas diff --git a/build.sh b/build.sh index c99a4fc..926a219 100755 --- a/build.sh +++ b/build.sh @@ -26,6 +26,7 @@ UNITS=( src/ma.events.pas src/ma.lock.pas src/ma.paths.pas + src/ma.api.pas ) ALL_TARGETS=( diff --git a/docs/format-notes/dependencies.md b/docs/format-notes/dependencies.md index aacea57..1134af5 100644 --- a/docs/format-notes/dependencies.md +++ b/docs/format-notes/dependencies.md @@ -1,5 +1,20 @@ # External dependencies in copied format units +## Sample data + +Real message bases for testing live at `~/fidonet/msg/`: + +- `hudson/` — Hudson MSGINFO/IDX/HDR/TXT/TOIDX.BBS set +- `jam/` — many JAM echo areas (e.g. `10thamd.jhr/jdt/jdx/jlr`) +- `echomail.jam/` — extra JAM samples +- `netmail/` — FTS-1 *.MSG numbered files (mixed upper/lower case on disk) +- `squish/` — Squish bases (currently empty but layout reserved) +- `local/jam/`, `lowerit/`, `passthru/` — additional collections + +Tests should open these read-only and verify message counts, first/last +messages, and specific known attributes. Do NOT write to these paths +from tests — copy them into a scratch dir first. + ## Authoritative specs The FTSC document collection at `/home/ken/Source Code/ftsc/docs/` is the diff --git a/src/ma.api.pas b/src/ma.api.pas new file mode 100644 index 0000000..eb8ffa6 --- /dev/null +++ b/src/ma.api.pas @@ -0,0 +1,419 @@ +{ + message_api - unified BBS message base library + ma.api.pas - public facade: TMessageBase abstract class, factory + + Callers that want format-agnostic access go through TMessageBase + and the MessageBaseOpen / MessageBaseOpenAuto factories. Callers + that need a format's full native API keep using the format units + directly (ma.fmt.hudson etc.) -- both APIs coexist. + + Each format unit registers its concrete subclass in its + initialization section via RegisterMessageBaseClass. The factory + looks up the registration and instantiates the right subclass. +} + +unit ma.api; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + ma.types, ma.events, ma.lock, ma.paths; + +type + TMessageBase = class; + + { Factory function signature each backend registers. ABasePath is + the already-canonicalised path produced by MessageBasePathFor; + the backend should not re-derive it. } + TMessageBaseFactory = function(const ABasePath: AnsiString; + AMode: TMsgOpenMode): TMessageBase; + + EMessageBase = class(Exception); + + { TMessageBase - abstract root for every backend. + Descendants implement the DoXxx virtuals; the public methods + wrap them with event firing, locking, and validity checks. + Callers should always go through the public methods. } + TMessageBase = class + private + FFormat: TMsgBaseFormat; + FBasePath: AnsiString; + FAreaTag: AnsiString; + FMode: TMsgOpenMode; + FEvents: TMessageEvents; + FLock: TMessageLock; + FIsOpen: boolean; + FReadOnly: boolean; + FLockTimeoutMs: integer; + protected + { Subclasses fill these in their constructor or DoOpen. } + procedure SetFormat(AFormat: TMsgBaseFormat); + + { Abstract contract -- every backend implements these. } + function DoOpen: boolean; virtual; abstract; + procedure DoClose; virtual; abstract; + function DoMessageCount: longint; virtual; abstract; + function DoReadMessage(Index: longint; var Msg: TUniMessage): boolean; virtual; abstract; + function DoWriteMessage(var Msg: TUniMessage): boolean; virtual; abstract; + + { Optional: default implementations return False. } + function DoReIndex: boolean; virtual; + function DoPack(PurgeAgeDays, PurgeMaxCount: longint; + Backup: boolean): boolean; virtual; + function DoUpdateMessage(Index: longint; + var Msg: TUniMessage): boolean; virtual; + function DoDeleteMessage(Index: longint): boolean; virtual; + + { Helpers for subclasses. } + procedure FireEvent(EType: TMsgEventType; + const Msg: AnsiString; + ALongValue: int64 = 0); + procedure CheckOpen; + function AcquireLock(AKind: TLockKind): boolean; + procedure ReleaseLock; + public + constructor Create(AFormat: TMsgBaseFormat; + const ABasePath: AnsiString; + AMode: TMsgOpenMode); virtual; + destructor Destroy; override; + + { Open the base. Acquires layer-2 lock (shared or exclusive + depending on mode), then calls DoOpen. Fires metBaseOpened + on success. } + function Open: boolean; virtual; + procedure Close; virtual; + + function ReadMessage(Index: longint; + var Msg: TUniMessage): boolean; + function WriteMessage(var Msg: TUniMessage): boolean; + function UpdateMessage(Index: longint; + var Msg: TUniMessage): boolean; + function DeleteMessage(Index: longint): boolean; + + function ReIndex: boolean; + function Pack(PurgeAgeDays, PurgeMaxCount: longint; + Backup: boolean = True): boolean; + + property Format: TMsgBaseFormat read FFormat; + property BasePath: AnsiString read FBasePath; + property AreaTag: AnsiString read FAreaTag write FAreaTag; + property Mode: TMsgOpenMode read FMode; + property IsOpen: boolean read FIsOpen; + property ReadOnly: boolean read FReadOnly; + property MessageCount: longint read DoMessageCount; + property Events: TMessageEvents read FEvents; + property Lock: TMessageLock read FLock; + + { Timeout (ms) for cross-process lock acquisition. -1 = wait + forever. 0 = fail immediately if contended. } + property LockTimeoutMs: integer + read FLockTimeoutMs write FLockTimeoutMs; + end; + + { ---------- Registration & factory ---------- } + +procedure RegisterMessageBaseClass(AFormat: TMsgBaseFormat; + AFactory: TMessageBaseFactory); + +{ Factory: returns a not-yet-opened TMessageBase for the requested + format. AAreaPath + AAreaTag are run through MessageBasePathFor + so callers can pass area-configuration values directly. + Raises EMessageBase if the format has no registered backend. } +function MessageBaseOpen(AFormat: TMsgBaseFormat; + const AAreaPath: AnsiString; + AMode: TMsgOpenMode; + const AAreaTag: AnsiString = ''): TMessageBase; + +{ Autodetect: sniffs AAreaPath for signature files and picks the + right backend. Returns nil if no format matches. } +function MessageBaseOpenAuto(const AAreaPath: AnsiString; + AMode: TMsgOpenMode): TMessageBase; + +function DetectFormat(const AAreaPath: AnsiString; + out AFormat: TMsgBaseFormat): boolean; + +implementation + +var + { One factory per format; nil if not registered yet. } + gFactories: array[TMsgBaseFormat] of TMessageBaseFactory; + +{ ---------- TMessageBase ---------- } + +constructor TMessageBase.Create(AFormat: TMsgBaseFormat; + const ABasePath: AnsiString; + AMode: TMsgOpenMode); +begin + inherited Create; + FFormat := AFormat; + FBasePath := ABasePath; + FMode := AMode; + FReadOnly := AMode = momReadOnly; + FEvents := TMessageEvents.Create(Self); + FLock := TMessageLock.Create(LockFilePath(AFormat, ABasePath), FEvents); + FIsOpen := False; + FLockTimeoutMs := 30000; +end; + +destructor TMessageBase.Destroy; +begin + if FIsOpen then + try Close except end; + FLock.Free; + FEvents.Free; + inherited Destroy; +end; + +procedure TMessageBase.SetFormat(AFormat: TMsgBaseFormat); +begin + FFormat := AFormat; +end; + +procedure TMessageBase.FireEvent(EType: TMsgEventType; + const Msg: AnsiString; + ALongValue: int64); +begin + FEvents.FireSimple(EType, FBasePath, Msg, ALongValue); +end; + +procedure TMessageBase.CheckOpen; +begin + if not FIsOpen then + raise EMessageBase.Create('Message base not open: ' + FBasePath); +end; + +function TMessageBase.AcquireLock(AKind: TLockKind): boolean; +begin + Result := FLock.Acquire(AKind, FLockTimeoutMs); +end; + +procedure TMessageBase.ReleaseLock; +begin + FLock.Release; +end; + +function TMessageBase.Open: boolean; +var + kind: TLockKind; +begin + Result := False; + if FIsOpen then begin Result := True; exit; end; + + if FReadOnly then kind := lkShared else kind := lkExclusive; + if not AcquireLock(kind) then exit; + + try + Result := DoOpen; + if Result then begin + FIsOpen := True; + FireEvent(metBaseOpened, MSG_BASE_FORMAT_NAME[FFormat]); + end else begin + ReleaseLock; + end; + except + on E: Exception do begin + ReleaseLock; + FireEvent(metError, 'Open failed: ' + E.Message); + raise; + end; + end; +end; + +procedure TMessageBase.Close; +begin + if not FIsOpen then exit; + try + DoClose; + finally + FIsOpen := False; + ReleaseLock; + FireEvent(metBaseClosed, MSG_BASE_FORMAT_NAME[FFormat]); + end; +end; + +function TMessageBase.ReadMessage(Index: longint; + var Msg: TUniMessage): boolean; +begin + CheckOpen; + Result := DoReadMessage(Index, Msg); + if Result then + FireEvent(metMessageRead, '', Index); +end; + +function TMessageBase.WriteMessage(var Msg: TUniMessage): boolean; +begin + CheckOpen; + if FReadOnly then + raise EMessageBase.Create('Cannot write to read-only base'); + Result := DoWriteMessage(Msg); + if Result then + FireEvent(metMessageWritten, '', Msg.MsgNum); +end; + +function TMessageBase.UpdateMessage(Index: longint; + var Msg: TUniMessage): boolean; +begin + CheckOpen; + if FReadOnly then + raise EMessageBase.Create('Cannot update read-only base'); + Result := DoUpdateMessage(Index, Msg); + if Result then + FireEvent(metMessageUpdated, '', Index); +end; + +function TMessageBase.DeleteMessage(Index: longint): boolean; +begin + CheckOpen; + if FReadOnly then + raise EMessageBase.Create('Cannot delete from read-only base'); + Result := DoDeleteMessage(Index); + if Result then + FireEvent(metMessageDeleted, '', Index); +end; + +function TMessageBase.ReIndex: boolean; +begin + CheckOpen; + if FReadOnly then + raise EMessageBase.Create('Cannot reindex read-only base'); + FireEvent(metReindexStarted, ''); + Result := DoReIndex; + if Result then FireEvent(metReindexComplete, ''); +end; + +function TMessageBase.Pack(PurgeAgeDays, PurgeMaxCount: longint; + Backup: boolean): boolean; +begin + CheckOpen; + if FReadOnly then + raise EMessageBase.Create('Cannot pack read-only base'); + FireEvent(metPackStarted, ''); + Result := DoPack(PurgeAgeDays, PurgeMaxCount, Backup); + if Result then FireEvent(metPackComplete, ''); +end; + +{ Default implementations for optional virtuals -- backends that + don't support these return False rather than raising. } + +function TMessageBase.DoReIndex: boolean; +begin + Result := False; +end; + +function TMessageBase.DoPack(PurgeAgeDays, PurgeMaxCount: longint; + Backup: boolean): boolean; +begin + Result := False; +end; + +function TMessageBase.DoUpdateMessage(Index: longint; + var Msg: TUniMessage): boolean; +begin + Result := False; +end; + +function TMessageBase.DoDeleteMessage(Index: longint): boolean; +begin + Result := False; +end; + +{ ---------- Registration ---------- } + +procedure RegisterMessageBaseClass(AFormat: TMsgBaseFormat; + AFactory: TMessageBaseFactory); +begin + gFactories[AFormat] := AFactory; +end; + +function MessageBaseOpen(AFormat: TMsgBaseFormat; + const AAreaPath: AnsiString; + AMode: TMsgOpenMode; + const AAreaTag: AnsiString): TMessageBase; +var + canonical: AnsiString; +begin + if gFactories[AFormat] = nil then + raise EMessageBase.Create('No backend registered for ' + + MSG_BASE_FORMAT_NAME[AFormat] + + ' — add its unit to your uses clause.'); + canonical := MessageBasePathFor(AFormat, AAreaPath, AAreaTag); + Result := gFactories[AFormat](canonical, AMode); + Result.FAreaTag := AAreaTag; +end; + +function DetectFormat(const AAreaPath: AnsiString; + out AFormat: TMsgBaseFormat): boolean; +var + dir, tmp: AnsiString; + searchRec: TSearchRec; + rc: integer; +begin + Result := False; + dir := PathAppendSep(AAreaPath); + + { Hudson: MSGINFO.BBS + MSGHDR.BBS } + if FileExists(FindExistingFile(dir + 'MSGINFO.BBS')) and + FileExists(FindExistingFile(dir + 'MSGHDR.BBS')) then begin + AFormat := mbfHudson; Result := True; exit; + end; + + { GoldBase: MSGINFO.DAT + MSGHDR.DAT } + if FileExists(FindExistingFile(dir + 'MSGINFO.DAT')) and + FileExists(FindExistingFile(dir + 'MSGHDR.DAT')) then begin + AFormat := mbfGoldBase; Result := True; exit; + end; + + { JAM: any *.JHR + matching *.JDT } + rc := FindFirst(dir + '*.jhr', faAnyFile, searchRec); + try + if rc = 0 then begin + tmp := ChangeFileExt(searchRec.Name, '.jdt'); + if FileExists(FindExistingFile(dir + tmp)) then begin + AFormat := mbfJam; Result := True; exit; + end; + end; + finally + FindClose(searchRec); + end; + + { Squish: any *.SQD + matching *.SQI } + rc := FindFirst(dir + '*.sqd', faAnyFile, searchRec); + try + if rc = 0 then begin + tmp := ChangeFileExt(searchRec.Name, '.sqi'); + if FileExists(FindExistingFile(dir + tmp)) then begin + AFormat := mbfSquish; Result := True; exit; + end; + end; + finally + FindClose(searchRec); + end; + + { FTS-1 MSG: numbered *.MSG files } + rc := FindFirst(dir + '*.msg', faAnyFile, searchRec); + try + if rc = 0 then begin + AFormat := mbfMsg; Result := True; exit; + end; + finally + FindClose(searchRec); + end; +end; + +function MessageBaseOpenAuto(const AAreaPath: AnsiString; + AMode: TMsgOpenMode): TMessageBase; +var + fmt: TMsgBaseFormat; +begin + if DetectFormat(AAreaPath, fmt) then + Result := MessageBaseOpen(fmt, AAreaPath, AMode) + else + Result := nil; +end; + +initialization + FillChar(gFactories, SizeOf(gFactories), 0); +end.