const
CurtailLimit= 256; (* Default limit and slop *)
CurtailSlop= 32; (* This is a fraction since +ve *)
var
CurtailedMemoFteTimeout: integer= 90; (* Seconds *)
(* This is typically used to keep the total number of lines in a TMemo etc.
below some limit, so that the resources it consumes do not start to impose a
bottleneck; this should also be called regularly (say every minute) without a
lines parameter to update an internal counter. The return value is the number
of characters deleted, including line-ends.
If the blockText parameter is false then deletion is of individual lines at
the start of the memo, otherwise it continues until it reaches a blank line
assumed to indicate the end of a block or paragraph which is also deleted. If
hasBeenVisible is false no attempt is made to save and restore the caret
position, avoiding the penalty of handling an internal exception if text is
being sent to a form known to be hidden.
If the slop parameter is +ve then it indicates the fraction by which the size
is allowed to "hunt" around the limit; +1 is a special case indicating that
there should be no deletion. If the slop parameter is -ve then it is a number
of lines rather than a fraction; -1 is a special case indicating a default.
*)
function CurtailedAppend(const memo: TCustomMemo; const line: ansistring= #$7f;
blockText: boolean= false; hasBeenVisible: boolean= true;
limit: longword= CurtailLimit; slop: integer= -1): integer;
{$define USE_TAG_FOR_TIMEOUT }
const
ZeroPt: TPoint= (X: 0; Y: 0);
var
caret: TPoint;
trimmedLines, halfSlop: integer;
forceToEnd: boolean= false;
{$ifdef USE_TAG_FOR_TIMEOUT }
procedure setTimer(t: longword);
begin
if t = 0 then
memo.Tag := 0 (* Zero/nil is valid *)
else
memo.Tag := ptruint(t << 1) or 1 (* Otherwise must not look like pointer *)
end { setTimer } ;
function getTimer(): longword;
begin
result := longword(memo.Tag >> 1)
end { getTimer } ;
{$else }
(* Do not declare a static variable for the force-to-end timer if this will be *)
(* called in the context of more than one memo. *)
// timer: qword= 0; (* Static variable *)
procedure setTimer(t: longword);
begin
{$if declared(timer) }
timer := t
{$endif }
end { setTimer } ;
function getTimer(): longword;
begin
{$if declared(timer) }
result := timer
{$else }
result := 0
{$endif }
end { getTimer } ;
{$endif }
begin
result := 0;
memo.Lines.BeginUpdate;
try
(* Save caret position on entry, with special provision for a hidden pane to *)
(* avoid a "GetCaretPos called without handle" error. *)
if hasBeenVisible then
try
caret := memo.CaretPos
except
caret := zeroPt
end
else
caret := zeroPt;
(* Initialise the slop and/or limit where not explicitly specified. Slop values *)
(* of -1 and +1 are chosen to indicate the default and no-deletion cases since *)
(* (-1 div 2) lines is zero and (limit / +1) would result in no retained output *)
(* which makes these parameter values redundant. *)
case Sign(slop) of
-1: if slop = -1 then
halfSlop := (limit div CurtailSlop) div 2
else
halfSlop := -slop div 2; (* Slop was number of lines *)
0: halfSlop := 0;
1: halfSlop := (limit div slop) div 2 (* Slop was denominator *)
end;
(* If the cursor (as distinct from scrollbar) has been placed at some position *)
(* other that the end of the displayed text then there will not be an automatic *)
(* jump to the end as soon as more output arrives. However this is subject to a *)
(* timeout so that if the operator is not actively investigating older messages *)
(* the memo reverts to a state where it is the newer ones that are displayed. *)
trimmedLines := memo.Lines.Count; (* Visible for debugging *)
forceToEnd := not (caret.Y < trimmedLines - 1);
if (not forceToEnd) and (getTimer() = 0) then
setTimer(UnixNow);
trimmedLines := 0;
try
(* If the line contains (only) a <Del> character then this is a dummy operation *)
(* (typically invoked by a timer) with the intention of reverting to the end if *)
(* the timeout has expired. In practice, don't delete any lines from the start *)
(* if the user has scrolled up and is trying to read stuff. *)
if line <> #$7f then begin
if getTimer() = 0 then begin
if (slop <> 1) and (memo.Lines.Count > limit + halfSlop) then begin
while memo.Lines.Count > limit - halfSlop do begin
result += memo.Lines[0].Length + 1;
memo.Lines.Delete(0);
trimmedLines += 1;
if caret.Y > 0 then
caret.Y -= 1
end;
(* If that's left us on a non-blank line then advance to the next blank line, *)
(* then one more to get rid of that as well. *)
if blockText then begin
while (memo.Lines.Count > 0) and (memo.Lines[0] <> '') do begin
result += memo.Lines[0].Length + 1;
memo.Lines.Delete(0);
trimmedLines += 1;
if caret.Y > 0 then
caret.Y -= 1
end;
if (memo.Lines.Count > 0) and (memo.Lines[0] = '') then begin
result += memo.Lines[0].Length + 1;
memo.Lines.Delete(0);
trimmedLines += 1;
if caret.Y > 0 then
caret.Y -= 1
end
end
end
end;
(* Scrolling etc. behaviour above and in finally block below largely cribbed *)
(* from WatchP0x via PSTalk. *)
memo.Lines.Append(line)
end
finally
if forceToEnd or (UnixNow() - getTimer() > CurtailedMemoFteTimeout) then begin
if memo.Lines.Count > 0 then begin
caret.Y := memo.Lines.Count - 1;
caret.X := 0
end;
setTimer(0)
end
end;
(* Restore caret position on exit, with special provision for a hidden pane to *)
(* avoid the overhead of a "GetCaretPos called without handle" exception. *)
if hasBeenVisible then
try
memo.CaretPos := caret
except
end
finally
memo.Lines.EndUpdate
end
end { CurtailedAppend } ;
Recent
