{******************************************************************
 ***                  LONG STRINGS UNIT                         ***
 *** M Hill                                               Nov 95***
 ******************************************************************}
{$I compflgs}
{these give a few handy functions for dealing with "buffers" instead
of strings.  The advantage is a length limit of word (65535 chars), a
dynamic data space, and as the length is given you do not have to worry
about embedded nuls, unlike nul-terminated strings}
unit lstrings;

INTERFACE

const
	EndParaChar = #20;
	EndLine = #20#13#10;
	LSNotFound = 65535;

type
	PLongString = ^TLongString;
	TLongString = record
		MemSize : word;
		Length : word;  {starting at length, this can be used as TMemoData for editors, etc - see notes}
		Data : PChar;
	end;

{chopping/inserting strings}
procedure LSAppend(var Dest : TLongString; const Source : TLongString);
procedure LSAppendBlock(var Dest : TLongString; var Source; const StartPos, Length : word);

function LSGetChar(const Source : TLongString; const CharPos : word) : char;
procedure LSSetChar(var LString : TLongString; const CHarPos : word; C : char);

procedure LSDelete(var Dest : TLongString; const StartPos : word; Length : word);
procedure LSDeleteChar(var Dest : TLongString; const StartPos : word);

procedure LSInsert(var Dest : TLongString; const Source : TLongString; const StartPos : word);
procedure LSInsertStr(var Dest : TLongString; const Source : string; const StartPos : word);
procedure LSInsertChar(var Dest : TLongString; const Source : char; const StartPos : word);

procedure LSRemove(var LString : TLongString; const Ch : char); {removes all char from lstring}

procedure LSCopy(var Dest : TLongString; const Source : TLongString; const StartPos, Length : word);
procedure LSOverwriteStr(var LString : TLongString; const S : string; const StartPos : word);

{string functions}
function LSGetLine(const LString : TLongString; const LineNo : word) : string;
function LSNumLines(const LString : TLongString) : word;

{formatting functions}
procedure LSReWidth(var LString : TLongString; const Width : word); {reformats soft breaks for new width}
procedure LSReWidthFrom(var LString : TLongString; const Width, Start : word); {reformats soft breaks for new width}
procedure LSJustify(var LString : TLongString; const Width,Justify : byte);
procedure LSJustifyFrom(var LString : TLongString; const Start : word; const Width,Justify : byte); {rewidth from a point}
procedure LSSetWidth(var LString : TLongString; const Width : byte);

{search/replace - returns 65535/LSNotFound if not found}
function LSPos(const SubStr : string; const LString : TLongString) : word;
function LSPosFrom(const SubStr : string; const LString : TLongString; StartPos : word) : word;

{string altering}
procedure LSUCase(var LString : TLongString);

{interface with normal strings}
procedure LSAppendStr(var Dest : TLongString; Source : string);
function LS2String(Source : TLongString) : string;
procedure String2LS(Source : string; var Dest : TLongString);
function LSGetString(const Source : TLongString; const StartPos,Length : word) : string;

{Returning info}
function LSLen(const LString : TLongString) : word;
{returns final X,Y pos of cursor at end of string}
procedure LSXYPos(const LString : TLongString; var XPos,YPos : word);

{admin functions}
procedure LSClear(var LString : TLongString);
procedure LSNew(var LString : TLongString);
procedure LSDispose(var LString : TLongString);
procedure LSExpand(var LString : TLongString; const NewSize : word);
procedure LSSetLen(var LString : TLongString; const NewLen : word);

IMPLEMENTATION

uses minilib;

{****************************************************
 ***           STRING PROCESSING                  ***
 ****************************************************}
type
	Bytes = array[0..65534] of byte;

procedure LSAppend(var Dest : TLongString; const Source : TLongString);
begin
  LSAppendBlock(Dest, Source.Data^, 0, LSLen(Source));

{	if Dest.MemSize<Dest.Length+Source.Length then
  	{Not enough memory - make new space & copy}
{		LSExpand(Dest, Dest.MemSize+Source.Length);

  {and append}
{  Move(Source.Data^, Dest.Data[Dest.Length], Source.Length);
  Dest.Length := Dest.Length + Source.Length;{}
end;

procedure LSAppendStr(var Dest : TLongString; Source : string);
begin
	LSAppendBlock(Dest, Source, 1, Length(Source));

{	if Dest.MemSize<Dest.Length+Length(Source) then
  	{Not enough memory - make new space & copy}
{		LSExpand(Dest, Dest.MemSize+Length(Source));

	{and append}
{  Move(Source[1], Dest.Data[Dest.Length], Length(Source));
  Dest.Length := Dest.Length + Length(Source);{}
end;

procedure LSOverwriteStr(var LString : TLongString; const S : string; const StartPos : word);
var W : word;
begin
	{Copy in text}
	for W := 1 to Length(S) do LSSetChar(LString, StartPos+W-1, S[W]);
end;

procedure LSAppendBlock(var Dest : TLongString; var Source; const StartPos, Length : word);
begin
	if Dest.MemSize<Dest.Length+Length then
		LSExpand(Dest, Dest.MemSize+Length);

  {and append}
  Move(Bytes(Source)[StartPos], Dest.Data[Dest.Length], Length);
  Dest.Length := Dest.Length + Length;
end;


{*******************************************************
 ***                 SEARCH/REPLACE                  ***
 *******************************************************}
function LSPos(const SubStr : string; const LString : TLongString) : word;
begin
	LSPos := LSPosFrom(SubStr, LString, 0);
end;

function LSPosFrom(const SubStr : string; const LString : TLongString; StartPos : word) : word;
var B : byte;
		CharPos : word;
		F : boolean;
begin
	F := False; {marks whether found or not}
	CharPos := StartPos;
	LSPosFrom := LSNotFound; {not found}
	while (CharPos<LString.Length) and not F do begin
		if LString.Data[CharPos] = SubStr[1] then begin
			F := True;
			B := 2;
			while F and (B<=length(SubStr)) do begin
				F := (LString.Data[CharPos+B-1]=Substr[B]);
				inc(B);
			end;
		end;
		inc(CharPos);
	end;
	if F then LSPosFrom := CHarPos -1;

end;

function LSGetChar(const Source : TLongString; const CharPos : word) : char;
begin
	if CharPos<Source.Length then LSGetChar := Source.Data[CharPos] else LSGetChar := #0;
end;

procedure LSSetChar;
begin
	if CharPos<LString.Length then LString.Data[CharPos] := C;
end;

procedure LSDelete(var Dest : TLongString; const StartPos : word; Length : word);
begin
	if StartPos<Dest.Length then begin
		if StartPos+Length>Dest.Length then Length := Dest.Length-StartPos;
		Move(Dest.Data[StartPos+Length], Dest.Data[StartPos], Dest.Length-StartPos-Length);
		Dest.Length := Dest.Length - Length;
	end else
		RunError(51); {Delete startpoint past end of string}
end;

procedure LSDeleteChar(var Dest : TLongString; const StartPos : word);
begin
	if StartPos<Dest.Length then begin
		Move(Dest.Data[StartPos+1], Dest.Data[StartPos], Dest.Length-StartPos-1);
		Dest.Length := Dest.Length - 1;
	end else
		RunError(51); {Delete startpoint past end of string}
end;

procedure LSRemove(var LString : TLOngstring; const Ch : char);
begin
	while LSPos(Ch, Lstring)<>LSNotFound do
		LSDeleteChar(LString, LSPos(Ch, LString));
end;

procedure LSInsGap(var Dest : TLongString; const StartPos : word; Length : word);
var P : PChar;
begin
{	if StartPos>Dest.MemSize then
		ProgramWarning('Trying to insert gap past end of reserved space','LSTRINGS LSInsGap');{}

	{can't do a straightforward Move because it'll tend to copy over itself
	so have to put memory aside to P.  Maybe a more efficient way of doing this}
  GetMem(P, Dest.Length-StartPos);
  Move(Dest.Data[StartPos], P^, Dest.Length-StartPos);
  Move(P^,Dest.Data[StartPos+Length], Dest.Length-StartPos);
  FreeMem(P, Dest.Length-StartPos);

  Dest.Length := Dest.Length + Length;
end;


{Inserts Source into Dest at StartPos}
procedure LSInsert(var Dest : TLongString; const Source : TLongString; const StartPos : word);
var P : pointer;
begin
  if StartPos<=Dest.Length then begin
  	{check size}
		if Dest.Length+Source.Length>Dest.MemSize then LSExpand(Dest, Dest.Length + Source.Length);

  	{Insert some space}
		LSInsGap(Dest, StartPos, Source.Length);

  	{copy}
		Move(Source.Data^, Dest.Data[StartPos], Source.Length);
	end else
  	RunError(50); {Insert point past end of string}
end;

{Inserts Source string into Dest at StartPos}
procedure LSInsertStr(var Dest : TLongString; const Source : string; const StartPos : word);
begin
  if StartPos<=Dest.Length then begin
  	{check size}
  	if Dest.Length+length(Source)>Dest.MemSize then LSExpand(Dest, Dest.Length + length(Source));

  	{Insert some space}
  	LSInsGap(Dest, StartPos, length(Source));

  	{copy}
		Move(Source[1], Dest.Data[StartPos], length(Source));
  end else
	 	RunError(50); {Insert point past end of string}
end;

{Inserts souce character into Dest at StartPos}
procedure LSInsertChar(var Dest : TLongString; const Source : char; const StartPos : word);
begin
	if StartPos<=Dest.Length then begin
		{check size}
		if Dest.Length>=Dest.MemSize then LSExpand(Dest, Dest.Length + 50);

		{Insert some space}
		LSInsGap(Dest, StartPos, 1);

		{copy}
		Dest.Data[StartPos] := Source;
	end else
		RunError(50); {Insert point past end of string}
end;

{sets Dest to an extract of Source starting at startpos of Length bytes}
procedure LSCopy(var Dest : TLongString; const Source : TLongString; const StartPos, Length : word);
begin
	if Length>Dest.MemSize then LSExpand(Dest, Length);
  Move(Source.Data[Startpos],Dest.Data^, Length);
  Dest.Length :=Length;
end;

{**********************************************
 ***          STRING FORMATTING             ***
 **********************************************}

procedure LSUCase(var LString : TLongString);
var W :word;
begin
	for W:=0 to LString.length do
		LString.Data[W] := UPcase(Lstring.Data[W]); {upper case each character}
end;


{**********************************************
 ***      INTERFACING WITH NORMAL STRINGS   ***
 **********************************************}

function LS2String(Source : TLongString) : string;
var S : string;
begin
	if Source.Length<256 then S[0] := char(Source.Length and $FF) else S[0] := #255;
  Move(Source.Data^, S[1], length(S));
	LS2String := S;
end;

procedure String2LS(Source : string; var Dest : TLongString);
begin
	if Dest.MemSize<length(Source) then LSExpand(Dest,length(Source));
	Dest.Length := length(Source);
	Move(Source[1], Dest.Data^, length(Source));
end;

function LSGetString(const Source : TLongString; const StartPos,Length : word) : string;
var S : String;
begin
	if Length<=255 then begin
		S[0] := char(Length); {set string length}
		Move(Source.Data[StartPos], S[1], Length);
		LSGetString := S;
	end else begin
		LSGetString := LSGetString(Source, StartPos, 255);
	end;
end;

{-------- Extract line n ---------------}
function LSGetLine(const LString : TLongString; const LineNo : word) : string;
var BufPos,LineCount : integer;
		S : string;
begin
	LineCount := 1;  {LineNo}
	BufPos := 0;  {Character no}
	S := '';

	while (LIneCount<LineNo) and (BufPos<LString.Length) do begin
		if LSGetChar(LString, BufPos)=#13 then begin
			inc(LineCount);
			inc(BufPos,1); {skip cr}
		end;
		inc(BufPos);
	end;

	if (LineCount=LineNo) then
		while (BufPos<LString.Length) and (LSGetChar(LString, BufPos)<>#13) and (LSGetChar(LString, BufPos)<>EndParaChar) do begin
			S := S + LSGetChar(LString, BufPos);
			inc(BufPos);
		end;

	LSGetLine := S;
end;

function LSNumLines(const LString : TLongString) : word;
var C : integer;
		L : integer;
begin
	if LString.Length =0 then L := 0 else L := 1; {no lines if no text - 1 line if some}
	for C := 1 to LString.Length do if LSGetChar(LString,C)=#10 then inc(L);
	LSNumLines := L;
end;

{**********************************************
 ***          RETURNS DETAILS               ***
 **********************************************}

function LSLen(const LString : TLongString) : word;
begin
	LSLen := LString.Length;
end;

procedure LSXYPos(const LString : TLongString; var XPos,YPos : word); {returns final X,Y pos of cursor at end of string}
var W : word;
begin
	{Count up CRLF's & chars since last work out new CodeXPos & CodeYPos}
	{count through number of CRLF's and number of characters afterwards}
	W := LSPos(#13#10, LString);
	XPos := XPos + LSLen(LString);

	while W<>LSNotFound do begin
		inc(YPos);
		XPos := LSLen(LString)-W-2; {characters left after CRLF}
		W := LSPosFrom(#13#10, LString, W+1);
	end;
end;

{**********************************************
 ***             RE-WRAPPING                ***
 **********************************************}
{-------- Reformat for a new width -------------}
{leave any excess *spaces* that overrun the width criteria}
{pass width as 0 to prepare for printing forms - ie returns only at para-breaks}
procedure LSReWidth(var LString : TLongString; const Width : word);
begin
	LSReWidthFrom(LString, Width, 0);
end;

procedure LSReWidthFrom(var LString : TLongString; const Width,Start : word);
var CharPos, GapPos : word;
		LineLength : word;
begin
	if Width < 0 then exit; {leave...}

	CharPos := Start;
	LineLength := 0;
	while CharPos<LString.Length do begin

		if LSGetChar(LString, CharPos)=EndParaChar then begin
			inc(CharPos,2); {skip over following CRLF to next line}
			LineLength := 0;
		end;

		if LSGetChar(LString, CharPos)=#13 then begin
			{just cr(lf) - no endpara so soft, remove}
			if LSGetChar(Lstring, CHarPos+1)=#10 then
				LSDelete(LString, CharPos, 2) {remove CRLF}
			else
				LSDelete(LString, CharPos, 1); {remove CR}

			if (CharPos>0) and (LSGetChar(LString, CharPos-1)<>' ') and (LSGetChar(LString, CharPos)<>' ') then
				LSInsertStr(LString, ' ', CharPos); {insert space if not one there}
		end;

		if (Width>0) and (LineLength>=Width) and (LSGetChar(LString, CharPos)<>' '){} then begin
			{overrun new width with a non-space - find beginning of word and insert crlf}
			GapPos := CharPos; {need to use separate var in case whole line is one word}

			{find break point}
			{move to last space/eol}
			while (GapPos>0) and (LSGetChar(LString, GapPos)<>#13)
				and (LSGetChar(LString, GapPos)<>#10) and (LSGetChar(LString, GapPos)<>' ') do dec(GapPos);

			if LSGetChar(LString, GapPos)=' ' then begin {there is a gap before}
				{found a gap before beginning of line - might be on charpos..}
				inc(GapPos, 1); {move to start of word}
				LSInsertStr(LString, #13#10, GapPos);
				LineLength := 0;
				CharPos := GapPos +2; {start again at beginning of new line}
			end;
		end;

		inc(CharPos);
		inc(LineLength);
	end;
end;

{********************************************
 ***           JUSTIFYING                 ***
 ********************************************}
{Lstring is a longstring giving the replacement text, Width specifies the
original bracket size and Justify is:
	juLeft = left,
	juCentre = centre,
	juRight = align right
	juFull = full justification (not done yet)!
{If the replacement string is more than one line, each line is set as on
it's own}
{If a line is too long, it is *truncated* to the right size}
procedure LSJustify(var LString : TLongString; const Width,Justify : byte);
begin
	LSJustifyFrom(Lstring, 0, Width, Justify);
end;

procedure LSJustifyFrom(var LString : TLongString; const Start: word; const Width,Justify : byte);
var   LineStart, LineEnd : word;
			Line : string;
begin
	{Extract each line as given by a CRLF and format it as above}
	{Takes a line at a time, deleting from Replace and then re-inserting}
	LSAppendStr(Lstring, CRLF); {to make sure last line is formatted}
	LineStart := Start;
	LineEnd := LSPosFrom(CRLF, LString, LineStart);
	while LineEnd<>LSNotFound do begin

		{cheats a bit, extracts normal pascal string & uses minilib routine}
		Line := LSGetString(LString, LineStart, LineEnd-LineStart);
		LSDelete(LString, LineStart, LineEnd-LineStart);
		JustifyLine(Line, Width, Justify);
		LSInsertStr(LString, Line, LineStart);

		LineStart := LineStart+Length(Line)+2; {move on to next line};
		LineEnd := LSPosFrom(CRLF, LString, LineStart);
	end;
	LSSetLen(LString, LSLen(LString)-2); {remove last crlf}
end;

{********************************************
 ***           SET WIDTH                  ***
 ********************************************}
{Sets the width of each line in LString to Width}
procedure LSSetWidth(var LString : TLongString; const Width : byte);
begin
	LSJustify(LString, Width, juLeft);
end;



{**********************************************
 ***          ADMIN                         ***
 **********************************************}
procedure LSNew(var LString : TLongString);
begin
	LString.Length := 0;
	LString.MemSize := 300;
	GetMem(LString.Data, LString.MemSize); {start with 300 bytes}
end;

procedure LSDispose(var LString : TLongString);
begin
	FreeMem(LString.Data, LString.MemSize); {start with 300 bytes}
  LString.Data := nil;
	LString.MemSize := 0;
	LString.Length := 0;
end;

{expands to new size}
procedure LSExpand(var LString : TLongString; const NewSize : word);
var P : pointer;
begin
	{Not enough memory - make new space & copy}
	GetMem(P, NewSize);
	Move(LString.Data^, P^, LString.Length);
	FreeMem(LString.Data, LString.MemSize);
	LString.Data := P;
	LString.MemSize  := NewSize;
end;

procedure LSClear(var LString : TLongString);
begin
	LString.Length := 0;
end;

procedure LSSetLen(var LString : TLongString; const NewLen : word);
begin
	if NewLen>LString.MemSize then LSExpand(LString, NewLen);
	if NewLen>LString.length then
		FillChar(LString.Data[LString.Length],NewLen-LString.Length, #32); {pad with spaces}
	LString.Length := NewLen;
end;

end.
