Thanks for your praise but the idea is fairly simple and has been around for
years. Below is commented code for an implementation that manages an update
routine. I think that it could be easily extended with some form of token
validation and a looping routine that will find the first token that is not
locked. Firebird is wonderful in that shortly after a client crash all locks
held by the crashed client are released.
I would also be interested in comments on my coding quality. Note that my
screen is (much) wider than it is high so I code longer lines to have shorter
routines.
{-------------------------------------------------------------------------------
select Id, LastAccess
from Mac$Tokens
where TokenGuid = ?TokenId
--------------------------------------------------------------------------------}
function TMoDm.TokenInHours(TokenId : TGuid;
CompareTime : TDateTime;
IntervalHours : integer) : boolean;
var
LastAccess : TDateTime;
begin
result := true;
if IntervalHours = 0 then Exit;
with ReadTokenQ do begin
Transaction.Active := true;
if not prepared then prepare;
paramByName('TokenId').asString := GUIDToString(TokenId);
ExecQuery;
LastAccess := fieldByName('LastAccess').asDateTime;
if Transaction.InTransaction then Transaction.Commit;
end;
{ ShowMessage('Last access = ' + FmtDateTime(LastAccess, false) + #13#10 +
'CompareTime = ' + FmtDateTime(CompareTime, false) + #13#10 +
'Interval: ' + intToStr(IntervalHours) + #13#10 +
'HourSpan: ' + intToStr(trunc(HourSpan(LastAccess,
CompareTime))));
}
result := trunc(HourSpan(LastAccess, CompareTime)) >= IntervalHours;
end;
{-------------------------------------------------------------------------------
This routine obtains a row lock on Mac$Tokens table
so that long running process won't collide;
Caller passes a Guid and a Query as var
if Guid is not known then Process registers it
Process then attempt to update row containing Guid
if lock obtained passes
fully set up query back to caller
true back to caller
else
Another process is doing the work
so
Query is freed and returns false
Token are like Tokens in Token ring networks
usage example
we would not want several processes calculating and inserting
bookings from RecurrentBookings at the same time because the same
booking would
be posted several times over
So before a Bookings from RecurrentBookings process runs
it attempts to get a token
if successful carries on
else drops out
NOTE
Transaction is left running to lock out other processes
It is only closed at end of update process
refuses token is less than interval hours since last access (LastAccess is
TimeStamp)
--------------------------------------------------------------------------------}
function TMoDm.GetToken(TokenId: TGuid;
var Query: TpFibQuery;
CompareDateTime : TDateTime;
IntervalHours : integer): boolean;
begin
result := false;
if not FindToken(TokenId) then
RegisterToken(TokenId);
if TokenInHours(TokenId, CompareDateTime, IntervalHours) then begin
Query := TpFibQuery.create(self);
with Query do begin
Database := MozDb;
Options := [qoTrimCharFields];
ParamCheck := true;
with Sql do begin
Clear;
add('Update Mac$Tokens ');
add('set LastAccess = ?LastAccess');
add('where TOKENGUID = ?TokenId');
end;
Transaction := TpFibTransaction.Create(self);
with Transaction do begin
DefaultDatabase := MozDb;
TimeoutAction := TARollBack;
//TPBMode := tpbReadCommitted;
Active := true;
end;
if not prepared then prepare;
paramByName('TokenId').asString := GUIDToString(TokenId);
paramByName('LastAccess').asDateTime := now;
try
ExecQuery;
result := true;
except
on E:Exception do begin
if Transaction.InTransaction then Transaction.RollBack;
result := false;
Transaction.free;
Query.free;
Query := nil;
end;
end;
end;
end;
end;
{-------------------------------------------------------------------------------
End run of GetToken
Commits transaction
releases Query
--------------------------------------------------------------------------------}
procedure TMoDm.ReleaseToken(TokenId: TGuid; var Query: TpFibQuery);
begin
if Query = nil then Exit;
with Query do begin
if transaction.InTransaction then Transaction.Commit;
Transaction.free;
Query.free;
Query := nil;
end;
end;
{-------------------------------------------------------------------------------
insert into Mac$Tokens
(TokenGuid)
values
(?TokenGuid)
--------------------------------------------------------------------------------}
procedure TMoDm.RegisterToken(TokenId: TGuid);
var
st : string;
begin
with MakeTokenQ do begin
try
transaction.active := true;
if not prepared then prepare;
paramByName('TokenGuid').asString := GUIDToString(TokenId);
ExecQuery;
if Transaction.InTransaction then Transaction.Commit;
except
on E:Exception do begin
if Transaction.InTransaction then Transaction.RollBack;
st := 'Error registering token!' + #13#10 + E.Message;
WriteToLog(llApErrors, st);
ShowMessage(st);
end;
end;
end;
end;
{-------------------------------------------------------------------------------
select count (Id)
from Mac$Tokens
where TokenGuid = ?TokenId
--------------------------------------------------------------------------------}
function TMoDm.FindToken(TokenId: TGuid): boolean;
begin
with FindTokenQ do begin
Transaction.Active := true;
if not prepared then prepare;
paramByName('TokenId').asString := GUIDToString(TokenId);
ExecQuery;
result := fields[0].asInteger > 0;
if transaction.Intransaction then Transaction.Commit;
end;
end;
Mick
