Add ma.api: TMessageBase abstract class, factory, format autodetect
This commit is contained in:
1
build.sh
1
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=(
|
||||
|
||||
@@ -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
|
||||
|
||||
419
src/ma.api.pas
Normal file
419
src/ma.api.pas
Normal file
@@ -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.
|
||||
Reference in New Issue
Block a user