Category : Pascal Source Code
Archive   : TPBMEM.ZIP
Filename : TPBKMEMO.INC

(*********************************************************}
(* TpBkMemo.inc *)
(* block editing procs for TpBkMemo.pas *)
(*********************************************************)
{---------------------------------------------------------------------------
initialization routines
----------------------------------------------------------------------------}
procedure InitBlockCommands;
{-adds user exit commands to TpMemo}
begin
{EMuser10 = begin block: ^KB, F7}
if not AddMemoCommand(EMuser10, 2, Ord(^K), Ord(^B)) then {};
if not AddMemoCommand(EMuser10, 1, $4100, 0) then {};

{EMuser11 = end block: ^KK, F8}
if not AddMemoCommand(EMuser11, 2, Ord(^K), Ord(^K)) then {};
if not AddMemoCommand(EMuser11, 1, $4200, 0) then {};

{EMuser12 = copy block: ^KC}
if not AddMemoCommand(EMuser12, 2, Ord(^K), Ord(^C)) then {};

{EMuser13 = move block: ^KV}
if not AddMemoCommand(EMuser13, 2, Ord(^K), Ord(^V)) then {};

{EMuser14 = write block: ^KW}
if not AddMemoCommand(EMuser14, 2, Ord(^K), Ord(^W)) then {};

{EMuser15 = read block: ^KR}
if not AddMemoCommand(EMuser15, 2, Ord(^K), Ord(^R)) then {};

{EMuser16 = delete block: ^KY}
if not AddMemoCommand(EMuser16, 2, Ord(^K), Ord(^Y)) then {};

{EMuser17 = hide block: ^KH}
if not AddMemoCommand(EMuser17, 2, Ord(^K), Ord(^H)) then {};
end;

{---------------------------------------------------------------------------
editing tools
----------------------------------------------------------------------------}
function CheckInsertOK(EMCB:EMControlBlock; N : word) : Boolean;
{-Return True if OK to insert N bytes into the edit buffer. Calls user
error handler if not OK.}
var
I : LongInt;
begin
with EMCB do begin
{allow a safety margin}
I := longint(TotalBytes)+longint(N)+longint(SafetyMargin);

if I <= BufSize then
CheckInsertOK := True
else begin
CheckInsertOK := False;
if MemoErrorPtr <> nil then
ErrorRoutine(EMCB,tmBufferFull);
end;
end;
end;

procedure ResetBlocking (var EMCB:EMControlBlock);
{-resets block offsets/flags}
begin
with EMCB do begin
BlockStart := 1;
BlockStartLine := 0;
BlockEnd := 1;
BlockEndLine := 0;
BlockActive := false;
BlockHidden := false;
end;
end;

{---------------------------------------------------------------------------
block updating / display highlighting tools
----------------------------------------------------------------------------}
procedure OffsetToLine (var EMCB:EMControlBlock);
{-converts block offset (start and end) to line number}
const
LF :char = ^J;
SearchFailed = $FFFF;
var
Loc :word;
Len :word;
Posn:word;
begin

with EMCB do begin
{convert blockstart to line}
BlockStartLine := 1;
Loc := 1;
Len := BlockStart;
repeat
Posn := Search(BufPtr^[Loc], Len, LF, 1);
if Posn <> SearchFailed then begin
inc (BlockStartLine);
inc (Loc,succ(Posn));
dec (Len,succ(Posn));
end;
until (Posn = SearchFailed) or (Len < 1);

{convert blockend to line}
BlockEndLine := BlockStartLine;
Loc := BlockStart;
Len := BlockEnd - BlockStart;
repeat
Posn := Search(BufPtr^[Loc], Len, LF, 1);
if Posn <> SearchFailed then begin
inc (BlockEndLine);
inc (Loc,succ(Posn));
dec (Len,succ(Posn));
end;
until (Posn = SearchFailed) or (Len < 1);
if Posn <> SearchFailed then
dec (BlockEndLine);
end;
end;

procedure UpdateBlock (var EMCB: EMControlblock;
SrcOfs,DstOfs:Word);
{-uses same args as Move(....), but updates block offsets instead}
var
AdjustLen : Word;
begin

{calulate adjustment length}
AdjustLen := abs(longint(SrcOfs) - longint(DstOfs));

{update block offsets}
with EMCB do begin
{adding space to buffer}
if SrcOfs < DstOfs then begin

{does this push the BlockStart ahead?}
if BlockStart > BufPos then
inc (BlockStart,AdjustLen);

{does this push the BlockEnd ahead?}
if BlockEnd > BufPos then
inc (BlockEnd,AdjustLen);
end

{removing space from buffer}
else begin

{does this pull BlockStart back?}
if BlockStart > BufPos then
dec (BlockStart,AdjustLen);

{does this pull BlockEnd back?}
if BlockEnd > BufPos then
dec (BlockEnd,AdjustLen);
end;

{block still valid?}
if BlockEnd <= BlockStart then
begin
BlockActive := false;
exit;
end;

{convert block offsets to lines}
OffsetToLine (EMCB);
end;
end;

{---------------------------------------------------------------------------
block activity tools
----------------------------------------------------------------------------}
procedure SetBlockOffset (var EMCB: EMControlBlock;
var ofs,line : word; Next:boolean);
{-sets block offsets (start or end) to current bufpos}
var
i:word;
begin
with EMCB do begin
line := CurLine;

{next means place the mark at the beginning of the next line}
if Next then
if CurLine = TotalLines then
ofs := TotalBytes
else
ofs := FindLineIndex (EMCB,succ(CurLine))
else
ofs := BufPos;
BlockActive := (BlockStart < BlockEnd);
BlockHidden := false;
end;
end;

{$F+}
function HeapFunc(Size : Word) : Integer;
{-Return nil pointer if insufficient memory}
begin
HeapFunc := 1;
end;
{$IFDEF FMinus}
{$F-}
{$ENDIF}

procedure CopyMarkedBlock (var EMCB:EMControlBlock; MoveIt:boolean);
{-copies the marked block to the current location (with optional delete)}
type
ScratchArray = array[1..65535] of char;
var
Scratch : ^ScratchArray;
I,J:word;

function GetMemCheck(var P; Bytes : Word) : Boolean;
{-Allocate heap space, returning true if successful}
var
Pt : Pointer absolute P;
SaveHeapError : Pointer;
begin
{Take over heap error control}
SaveHeapError := HeapError;
HeapError := @HeapFunc;
GetMem(Pt, Bytes);
GetMemCheck := (Pt <> nil);
{Restore heap error control}
HeapError := SaveHeapError;
end;

begin

with EMCB do begin
{is there an active block?}
if not BlockActive or BlockHidden then
exit;

{don't allow copying if the cursor is in the block}
if (BufPos > BlockStart) and (BufPos < BlockEnd) then
exit;

{get current blocklen}
BlockLen := BlockEnd - BlockStart;

{make sure there's room}
if CheckInsertOK (EMCB,BlockLen) and
GetMemCheck (Scratch,BlockLen) then begin

Move (BufPtr^[BlockStart],Scratch^,BlockLen);

{create an opening in the text buffer}
Move (BufPtr^[BufPos],BufPtr^[BufPos+BlockLen],
succ(TotalBytes-BufPos));

{move in the scratch buffer}
Move (Scratch^,BufPtr^[BufPos],BlockLen);

{if this is a move delete the marked block}
if MoveIt then begin

{if its a move backward, adjust the block offsets first}
if pred(BufPos) < BlockStart then begin
inc (BlockStart, BlockLen);
inc (BlockEnd, BlockLen);
end;

{delete the old block}
Move (BufPtr^[BlockEnd],BufPtr^[BlockStart],
Succ(TotalBytes+BlockLen)-BlockEnd);

{if move forward, adjust bufpos}
if pred(BufPos) > BlockStart then
dec (BufPos,BlockLen);
end
else begin
{adjust totals}
inc (TotalBytes,BlockLen);
I := 1;
repeat
J := Search(Scratch^[I], succ(BlockLen-I), CRLF, 2);
if J <> SearchFailed then begin
Inc(TotalLines);
Inc(I, J+2);
end;
until (J = SearchFailed) or (I >= BlockLen);
end;

{update block offsets to point to moved/copied block}
SetBlockOffset (EMCB, BlockStart, BlockStartLine, false);
BlockEnd := BlockStart + BlockLen;
OffsetToLine (EMCB);
BlockActive := BlockStart < BlockEnd;

{make sure current position is start of block}
BufPos := BlockStart;
CurLine := BlockStartLine;
CurCol := 1;

{cleanup}
FreeMem (Scratch,BlockLen);
Modified := true;
end;
end;
end;

function WriteMarkedBlock (EMCB:EMControlBlock;
var fname:string): MemoStatusType;
{- writes marked block}
var
f:file;
BytesWritten :word;
begin
with EMCB do begin
if not BlockActive or BlockHidden then
exit;

{open a file}
Assign(f, fname);
Rewrite(f, 1);
if IoResult <> 0 then begin
WriteMarkedBlock := mstCreationError;
Close(f);
Exit;
end;

{write the marked block}
BlockLen := BlockEnd - BlockStart;
BlockWrite(f, BufPtr^[BlockStart], BlockLen, BytesWritten);
if (BytesWritten <> BlockLen) or (IoResult <> 0) then begin
WriteMarkedBlock := mstWriteError;
Close(f);
Exit;
end;

{normal completion}
Close (f);
end;
end;

function ReadMarkedBlock (var EMCB:EMControlBlock;
var fname:string):MemoStatusType;
{- reads block into file}
var
f :file;
BytesToRead :word;
BytesRead :word;
I,J :word;
begin

{assume file not found error}
ReadMarkedBlock := mstNotFound;

with EMCB do begin
{try to open file}
Assign(f, fname);
Reset(f, 1);
i := IoResult;

{check for invalid pathname}
if i = 3 then
ReadMarkedBlock := mstInvalidName;

if i <> 0 then
Exit;

{check total buffer size}
BytesToRead := FileSize(f);

{is there room?}
if not CheckInsertOK(EMCB,BytesToRead) then begin
ReadMarkedBlock := mstOK; {error already handled}
exit;
end;

{make room for the block}
Move (BufPtr^[BufPos],
BufPtr^[BufPos+BytesToRead],
TotalBytes-((BufPos)-2));

{read the file into the buffer}
BlockRead(F, BufPtr^[BufPos], BytesToRead, BytesRead);
if (BytesRead <> BytesToRead) then begin
ReadMarkedBlock := mstReadError;
Close(f);
I := IoResult;
end
else begin
Close(f);
if IoResult = 0 then
ReadMarkedBlock := mstOK
end;

{update totals}
Modified := true;
TotalBytes := TotalBytes + BytesToRead;
TotalLines := 1;
I := 1;
repeat
J := Search(BufPtr^[I], succ(TotalBytes-I), CRLF, 2);
if J <> SearchFailed then begin
Inc(TotalLines);
Inc(I, J+2);
end;
until (J = SearchFailed) or (I >= TotalBytes);

{update block offsets to point to block}
KnownLine := 1;
KnownOfs := 1;
SetBlockOffset (EMCB, BlockStart, BlockStartLine, false);
BlockEnd := BlockStart + BytesRead;
OffsetToLine (EMCB);
BlockActive := true;
BlockHidden := false;
end;
end;

procedure DeleteMarkedBlock (var EMCB:EMControlBlock);
{-delete the marked block from the text buffer}
var
I,J:word;
begin

with EMCB do begin

if not BlockActive or BlockHidden then
exit;

{delete it}
BlockLen := BlockEnd - BlockStart;
Move (BufPtr^[BlockEnd],BufPtr^[BlockStart],
Succ(TotalBytes+BlockLen)-BlockEnd);

{adjust totals}
dec(TotalBytes,BlockLen);
I := 1;
TotalLines := 1;
repeat
J := Search(BufPtr^[I], succ(TotalBytes-I), CRLF, 2);
if J <> SearchFailed then begin
Inc(TotalLines);
Inc(I, J+2);
end;
until (J = SearchFailed) or (I >= TotalBytes);

{set cursor position}
if TotalBytes <= 1 then begin
BufPtr^[1] := ^Z;
LineAtTop := 1;
BufPosTop := 1;
BufPos := 1;
TotalLines := 1;
CurLine := 1;
CurCol := 1;
KnownLine := 1;
KnownOfs := 1;
end
else begin
{move cursor to beginning of deleted block}
BufPos := BlockStart;
CurLine := BlockStartLine;
CurCol := 1;
LineAtTop := CurLine;
BufPosTop := BufPos;
KnownLine := 1;
KnownOfs := 1;
ResetBlocking (EMCB);
end;

{reset block pointers}
ResetBlocking (EMCB);
Modified := true;
end
end;

procedure HideMarkedBlock (var EMCB:EMControlBlock);
{-toggles BlockHidden}
begin
with EMCB do
if BlockActive then
BlockHidden := not BlockHidden;
end;