[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]
{$S-,R-,V-,I-,B-,F+}
{$IFNDEF Ver40}
{$I OPLUS.INC}
{$ENDIF}
{*********************************************************}
{* TPWRDSTR.PAS 1.0 *}
{* Copyright (c) Ken Henderson 1990. *}
{* *}
{* *}
{* All rights reserved. *}
{*********************************************************}
unit TPWrdStr;
{-Routines to support strings which use a word in the place of Turbo Pascal's
byte for holding the length of a string -- theoretically allowing strings
as large as 64k.}
interface
uses
TpString;
const
MaxWrdStr = 1024; {Maximum length of WrdStr - increase up to 65519}
NotFound = 0; {Returned by the Pos functions if substring not found}
type
WrdStr = array[-1..MaxWrdStr] of Char;
WrdStrPtr = ^WrdStr;
function WrdStr2Str(var A : WrdStr) : string;
{-Convert WrdStr to Turbo string, truncating if longer than 255 chars}
procedure Str2WrdStr(S : string; var A : WrdStr);
{-Convert a Turbo string into an WrdStr}
function LenWrdStr(A : WrdStr) : Word;
{-Return the length of an WrdStr string}
procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);
{-Return a substring of a. Note start=1 for first char in a}
procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);
{-Delete len characters of a, starting at position start}
procedure ConcatWrdStr(var A, B, C : WrdStr);
{-Concatenate two WrdStr strings, returning a third}
procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);
{-Concatenate a string to an WrdStr, returning a new WrdStr}
procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);
{-Insert WrdStr obj at position start of a}
procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);
{-Insert string obj at position start of a}
function PosStr(Obj : string; var A : WrdStr) : Word;
{-Return the position of the string obj in a, returning NotFound if not found}
function PosWrdStr(var Obja, A : WrdStr) : Word;
{-Return the position of obja in a, returning NotFound if not found}
function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;
{-Put WrdStr on heap, returning a pointer, nil if insufficient memory}
procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);
{-Return an WrdStr from the heap, empty if pointer is nil}
procedure DisposeWrdStr(P : WrdStrPtr);
{-Dispose of heap space pointed to by P}
function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;
{-Read an WrdStr from text file, returning true if successful}
function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;
{-Write an WrdStr to text file, returning true if successful}
procedure WrdStrUpcase(var A, B : WrdStr);
{-Uppercase the WrdStr in a, returning b}
procedure WrdStrLocase(var A, B : WrdStr);
{-Lowercase the WrdStr in a, returning b}
procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);
{-Return an WrdStr of length len filled with ch}
procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
{-Right-pad the WrdStr in a to length len with ch, returning b}
procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);
{-Right-pad the WrdStr in a to length len with blanks, returning b}
procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
{-Left-pad the WrdStr in a to length len with ch, returning b}
procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);
{-Left-pad the WrdStr in a to length len with blanks, returning b}
procedure WrdStrTrimLead(var A, B : WrdStr);
{-Return an WrdStr with leading white space removed}
procedure WrdStrTrimTrail(var A, B : WrdStr);
{-Return an WrdStr with trailing white space removed}
procedure WrdStrTrim(var A, B : WrdStr);
{-Return an WrdStr with leading and trailing white space removed}
procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);
{-Return an WrdStr centered in an WrdStr of Ch with specified width}
procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);
{-Return an WrdStr centered in an WrdStr of blanks with specified width}
function CompWrdStr(var a1, a2 : WrdStr) : Boolean;
{-Return equivalence of a1 and a2}
{==========================================================================}
implementation
const
Blank : char = #32;
function WrdStr2Str(var A : WrdStr) : string;
{-Convert WrdStr to Turbo string, truncating if longer than 255 chars}
var
S : string;
Len : Word absolute A;
Slen : byte Absolute S;
begin
if Len > 255 then SLen := 255
else Slen := Len;
Move(A[1], S[1], SLen);
WrdStr2Str := S;
end;
procedure Str2WrdStr(S : string; var A : WrdStr);
{-Convert a Turbo string into an WrdStr}
var
slen : byte absolute S;
alen : word absolute A;
begin
Move(S[1], A[1], slen);
alen := slen;
end;
function LenWrdStr(A : WrdStr) : Word;
{-Return the length of an WrdStr string}
var
alen : Word absolute A;
begin
LenWrdStr := alen;
end;
procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);
{-Return a substring of a. Note start=1 for first char in a}
var
alen : Word absolute A;
olen : Word absolute O;
begin
if Start > alen then
Olen := 0
else begin
{Don't copy more than exists}
if Start+Len > alen then
Len := Succ(alen-Start);
Move(A[Start], O[1], Len);
Olen := Len;
end;
end;
procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);
{-Delete len characters of a, starting at position start}
var
alen : Word Absolute A;
mid : Word;
begin
if Start <= alen then begin
{Don't do anything if start position exceeds length of string}
mid := Start+Len;
if mid <= alen then begin
{Move right remainder of string left}
Move(A[mid], A[Start], len);
Dec(alen,len);
end else
{Entire end of string deleted}
alen := Pred(Start);
end;
end;
procedure ConcatWrdStr(var A, B, C : WrdStr);
{-Concatenate two WrdStr strings, returning a third}
var
alen : Word absolute A;
blen : Word absolute B;
clen : Word absolute C;
temp : Word;
begin
{Put a into the result}
Move(A[1], C[1], alen);
{Store as much of b as fits into result}
Temp := blen;
if alen+blen > MaxWrdStr then
Temp := MaxWrdStr-alen;
Move(B[1], C[Succ(alen)], Temp);
{Terminate the result}
clen := alen+blen;
end;
procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);
{-Concatenate a string to an WrdStr, returning a new WrdStr}
var
alen : Word absolute A;
clen : Word absolute C;
slen : Byte absolute S;
begin
{Put a into the result}
Move(A[1], C[1], alen);
{Store as much of s as fits into result}
if alen+slen > MaxWrdStr then
slen := MaxWrdStr-alen;
Move(S[1], C[succ(alen)], slen);
{Terminate the result}
clen := alen+slen;
end;
procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);
{-Insert WrdStr obj at position start of a}
var
alen : Word absolute A;
olen : Word absolute Obj;
mid, temp : Word;
begin
if Start > alen then
{Concatenate if start exceeds alen}
Start := Succ(alen)
else begin
{Move right side characters right to make space for insert}
mid := Start+olen;
if mid <= MaxWrdStr then
{Room for at least some of the right side characters}
if alen+olen <= MaxWrdStr then
{Room for all of the right side}
Move(A[Start], A[mid], Succ(alen-Start))
else
{Room for part of the right side}
Move(A[Start], A[mid], Succ(MaxWrdStr-mid));
end;
{Insert the obj string}
temp := Olen;
if Start+olen > MaxWrdStr then
temp := Succ(MaxWrdStr-Start);
Move(Obj[1], A[Start], temp);
{Terminate the string}
if alen+olen <= MaxWrdStr then
Inc(alen,olen)
else
alen := MaxWrdStr;
end;
procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);
{-Insert string obj at position start of a}
var
alen : Word absolute A;
olen : byte absolute Obj;
mid,temp : Word;
begin
if Start > alen then
{Concatenate if start exceeds alen}
Start := succ(alen)
else begin
{Move right side characters right to make space for insert}
mid := Start+olen;
if mid <= MaxWrdStr then
{Room for at least some of the right side characters}
if alen+olen <= MaxWrdStr then
{Room for all of the right side}
Move(A[Start], A[mid], Succ(alen-Start))
else
{Room for part of the right side}
Move(A[Start], A[mid], Succ(MaxWrdStr-mid));
end;
{Insert the obj string}
temp := olen;
if Start+olen > MaxWrdStr then
temp := Succ(MaxWrdStr-Start);
Move(Obj[1], A[Start], temp);
{Terminate the string}
if alen+olen <= MaxWrdStr then
Inc(alen,olen)
else
alen := MaxWrdStr;
end;
{$L TPWrdStr}
function Search(var Buffer; BufLength : Word; var Match; MatLength : Word) : Word;
external;
procedure WrdStrUpcase(var A, B : WrdStr);
{-Upper case WrdStr A, returning it in B}
var
alen : Word absolute A;
x : Word;
begin
For x:=1 to alen do A[x]:=UpCase(A[x]);
Move(A,B,alen+2);
end;
procedure WrdStrLocase(var A, B : WrdStr);
{-Lower case WrdStr A, returning it in B}
var
alen : Word absolute A;
x : Word;
begin
For x:=1 to alen do A[x]:=LoCase(A[x]);
Move(A,B,alen+2);
end;
function CompWrdStr(var a1, a2 : WrdStr) : Boolean;
{-Compare WrdStr's a1 and a2 and return equivalence}
var
alen1 : Word absolute A1;
alen2 : Word absolute A2;
x : Word;
begin
CompWrdStr := false;
If (alen1=alen2) then {possibly equal, let's check it out}
begin
for x:=1 to alen1 do if (A1[x]<>A2[x]) then exit;
CompWrdStr := true; {If we made it to here, they must be equal}
end;
end;
function PosStr(Obj : string; var A : WrdStr) : Word;
{-Return the position of the string obj in a, returning NotFound if not found}
var
alen : Word absolute A;
olen : Byte absolute Obj;
PosFound : Word;
begin
PosFound := Search(A[1], alen, Obj[1], olen);
If (PosFound = $FFFF) then {Search didn't find it}
PosFound := 0;
PosStr := Succ(PosFound);
end;
function PosWrdStr(var Obja, A : WrdStr) : Word;
{-Return the position of obja in a, returning NotFound if not found}
var
alen : Word absolute A;
olen : Word absolute Obja;
PosFound : Word;
begin
PosFound := Search(A[1], alen, Obja[1], olen);
If (PosFound = $FFFF) then {Search didn't find it}
PosFound := 0;
PosWrdStr := Succ(PosFound);
end;
function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;
{-Put WrdStr on heap, returning a pointer, nil if insufficient memory}
var
alen : Word;
P : WrdStrPtr;
begin
alen := LenWrdStr(A)+2;
if MaxAvail >= alen then begin
GetMem(P, alen);
Move(A, P^, alen);
WrdStrToHeap := P;
end else
WrdStrToHeap := nil;
end;
procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);
{-Return an WrdStr from the heap, empty if pointer is nil}
var
alen : Word absolute a;
plen : Word absolute p;
begin
if P = nil then
Alen := 0
else
Move(P^, A, Plen+2);
end;
procedure DisposeWrdStr(P : WrdStrPtr);
{-Dispose of heap space pointed to by P}
begin
if P <> nil then
FreeMem(P, LenWrdStr(P^)+2);
end;
procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);
{-Return an WrdStr of length len filled with ch}
var
alen : Word absolute A;
begin
if Len = 0 then
Alen := 0
else begin
if Len > MaxWrdStr then
Len := MaxWrdStr;
FillChar(A[1], Len, Ch);
Alen := Len;
end;
end;
procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
{-Right-pad the WrdStr to length len with ch, returning b}
var
alen : Word Absolute A;
blen : Word Absolute B;
begin
if alen >= Len then
{Return the input string}
Move(A, B, alen+2)
else begin
if Len > MaxWrdStr then
Len := MaxWrdStr;
Move(A[1], B[1], alen);
FillChar(B[succ(alen)], Len-alen, Ch);
Blen := len;
end;
end;
procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);
{-Right-pad the WrdStr to length len with blanks, returning b}
begin
WrdStrPadCh(A, Blank, Len, B);
end;
procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
{-Left-pad the WrdStr in a to length len with ch, returning b}
var
alen : Word absolute A;
blen : Word absolute B;
begin
if alen >= Len then
{Return the input string}
Move(A, B, alen+2)
else begin
FillChar(B[1], Len-alen, Ch);
Move(A[1], B[Succ(Len-alen)], alen);
BLen := Len;
end;
end;
procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);
{-Left-pad the WrdStr in a to length len with blanks, returning b}
begin
WrdStrLeftPadCh(A, Blank, Len, B);
end;
procedure WrdStrTrimLead(var A, B : WrdStr);
{-Return an WrdStr with leading white space removed}
var
alen : Word absolute A;
apos : Word;
begin
apos := 1;
while (apos < alen) and (A[apos] <= Blank) do
Inc(apos);
Move(A[apos], B[1], Succ(alen-apos));
end;
procedure WrdStrTrimTrail(var A, B : WrdStr);
{-Return an WrdStr with trailing white space removed}
var
alen : Word absolute A;
blen : Word absolute B;
begin
while (alen > 1) and (A[Pred(alen)] <= Blank) do
Dec(alen);
Move(A, B, alen+2);
end;
procedure WrdStrTrim(var A, B : WrdStr);
{-Return an WrdStr with leading and trailing white space removed}
var
blen : Word Absolute B;
begin
WrdStrTrimLead(A, B);
while (blen > 1) and (B[Pred(blen)] <= Blank) do
Dec(blen);
end;
procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);
{-Return an WrdStr centered in an WrdStr of Ch with specified width}
var
alen : Word absolute A;
blen : Word absolute B;
begin
if alen >= Width then
{Return input}
Move(A, B, alen+2)
else begin
FillChar(B[1], Width, Ch);
Move(A[1], B[Succ((Width-alen) shr 1)], alen);
Blen := Width;
end;
end;
procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);
{-Return an WrdStr centered in an WrdStr of blanks with specified width}
begin
WrdStrCenterCh(A, Blank, Width, B);
end;
type
{text buffer}
TextBuffer = array[0..65520] of Byte;
{structure of a Turbo File Interface Block}
FIB = record
Handle : Word;
Mode : Word;
BufSize : Word;
Private : Word;
BufPos : Word;
BufEnd : Word;
BufPtr : ^TextBuffer;
OpenProc : Pointer;
InOutProc : Pointer;
FlushProc : Pointer;
CloseProc : Pointer;
UserData : array[1..16] of Byte;
Name : array[0..79] of Char;
Buffer : array[0..127] of Char;
end;
const
FMClosed = $D7B0;
FMInput = $D7B1;
FMOutput = $D7B2;
FMInOut = $D7B3;
CR : Char = ^M;
function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;
{-Read an WrdStr from text file, returning true if successful}
var
CrPos : Word;
alen : Word absolute A;
blen : Word;
function RefillBuf(var F : Text) : Boolean;
{-Refill buffer}
var
Ch : Char;
begin
with FIB(F) do begin
BufEnd := 0;
BufPos := 0;
Read(F, Ch);
if IoResult <> 0 then begin
{Couldn't read from file}
RefillBuf := False;
Exit;
end;
{Reset the buffer again}
BufPos := 0;
RefillBuf := True;
end;
end;
begin
with FIB(F) do begin
{Initialize the WrdStr length and function result}
alen := 0;
ReadLnWrdStr := False;
{Make sure file open for input}
if Mode <> FMInput then
Exit;
{Make sure something is in buffer}
if BufPos >= BufEnd then
if not(RefillBuf(F)) then
Exit;
{Use the Turbo text file buffer to build the WrdStr}
repeat
{Search for the next carriage return in the file buffer}
CrPos := Search(BufPtr^[BufPos], Succ(BufEnd-BufPos), CR, 1);
if CrPos = $FFFF then begin
{CR not found, save the portion of the buffer seen so far}
blen := BufEnd-BufPos;
if alen+blen > MaxWrdStr then
blen := MaxWrdStr-alen;
Move(BufPtr^[BufPos], A[alen], blen);
Inc(alen, blen);
{See if at end of file}
if eof(F) then begin
{Force exit with this line}
CrPos := 0;
{Remove trailing ^Z}
while (alen > 1) and (A[Pred(alen)] = ^Z) do
Dec(alen);
end else if not(RefillBuf(F)) then
Exit;
end else begin
{Save up to the CR}
blen := CrPos;
if alen+blen > MaxWrdStr then
blen := MaxWrdStr-alen;
Move(BufPtr^[BufPos], A[alen], blen);
Inc(alen, blen);
{Inform Turbo we used the characters}
Inc(BufPos, Succ(CrPos));
{Skip over following ^J}
if BufPos < BufEnd then begin
{Next character is within current buffer}
if BufPtr^[BufPos] = Ord(^J) then
Inc(BufPos);
end else begin
{Next character is not within current buffer}
{Refill the buffer}
if not(RefillBuf(F)) then
Exit;
if BufPos < BufEnd then
if BufPtr^[BufPos] = Ord(^J) then
Inc(BufPos);
end;
end;
until (CrPos <> $FFFF) or (alen > MaxWrdStr);
{Return success and terminate the WrdStr}
ReadLnWrdStr := True;
end;
end;
function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;
{-Write an WrdStr to text file, returning true if successful}
var
S : string;
alen : Word absolute A;
apos : Word;
slen : Byte absolute S;
begin
apos := 1;
WriteWrdStr := False;
{Write the WrdStr as a series of strings}
while apos < alen do begin
slen := alen-apos;
if slen > 255 then
slen := 255;
Move(A[apos], S[1], slen);
Write(F, S);
if IoResult <> 0 then
Exit;
Inc(apos, slen);
end;
WriteWrdStr := True;
end;
end.
{ ----------------- XX3402 Code for TPWRDSTR.OBJ ------------------}
{ Cut HERE and save save to a files (TPWRDSTR.XX). From DOS execute:
{ XX3402 D TPWRDSTR.XX to create TPWRDSTR.OBJ }
*XX3402-000257-280390--72--85-53814----TPWRDSTR.OBJ--1-OF--1
U+s+13FEJp72IpFG9Y3HHQq66++++3FpQa7j623nQqJhMalZQW+UJaJmQqZjPW+l9X+lW6UI
+21dk9Bw3+lII3RGF3BIIWt-IoqHW-E+ECaU83gG13FEEoxBHIxC9Y3HHLu6+k-+uImK+U++
O7M4++F1HoF3FNU5+0V0++6-+TCA4E+8JJ-1EJB3I377HE+8H2x1EJB3I377HE-TY+o+++24
IoJ-IYB6++++dcU2+20W+N4UFU+-++-JWykSzAFy1cjTWosAWpM4VR7o7AJq08l88wdq4z8i
RFS3obEAIJRKWwfndZtTKLLgHsj58wDf+nD+G-y9tJr80U+VWU6++5E+
***** END OF BLOCK 1 *****
{ ----------------------- CUT HERE ----------------------------------- }
{ ------------- ASSEMBLER CODE FOR TPWRDSTR.ASM ------------------- }
{ USE TASM TO COMPILE }
;******************************************************
; TPWRDSTR.ASM 1.0
; WrdStr string manipulation
; Copyright (c) TurboPower Software 1987.
; Portions copyright (c) Sunny Hill Software 1985, 1986
; and used under license to TurboPower Software
; All rights reserved.
;******************************************************
INCLUDE TPCOMMON.ASM
;****************************************************** Code
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC Search
EXTRN UpCasePrim : FAR
EXTRN LoCasePrim : FAR
Upcase MACRO ;UpCase character in AL
PUSH BX
CALL UpCasePrim
POP BX
ENDM
Locase MACRO ;LoCase character in AL
PUSH BX
CALL LoCasePrim
POP BX
ENDM
;****************************************************** Search
; function Search(var Buffer; BufLength : Word;
; var Match; MatLength : Word) : Word; external;
;Search through Buffer for Match.
;BufLength is length of range to search.
;MatLength is length of string to match
;Returns number of bytes searched to find St, FFFF if not found
;equates for parameters:
MatLength EQU WORD PTR [BP+6]
Match EQU DWORD PTR [BP+8]
BufLength EQU WORD PTR [BP+0Ch]
Buffer EQU DWORD PTR [BP+0Eh]
Search PROC FAR
StackFrameBP
PUSH DS ;Save DS
CLD ;Go forward
LES DI,Buffer ;ES:DI => Buffer
MOV BX,DI ;BX = Ofs(Buffer)
MOV CX,BufLength ;CX = Length of range to scan
MOV DX,MatLength ;DX = Length of match string
TEST DX,DX ;Length(Match) = 0?
JZ Error ;If so, we're done
LDS SI,Match ;DS:SI => Match buffer
LODSB ;AL = Match[1]; DS:SI => Match[2]
DEC DX ;DX = MatLength-1
SUB CX,DX ;CX = BufLength-(MatLength-1)
JBE Error ;Error if BufLength is less
;Search for first character in St
Next: REPNE SCASB ;Search forward for Match[1]
JNE Error ;Done if not found
TEST DX,DX ;If Length = 1 (DX = 0) ...
JZ Found ; the "string" was found
;Search for remainder of St
PUSH CX ;Save CX
PUSH DI ;Save DI
PUSH SI ;Save SI
MOV CX,DX ;CX = Length(St) - 1
REPE CMPSB ;Does rest of string match?
POP SI ;Restore SI
POP DI ;Restore DI
POP CX ;Restore CX
JNE Next ;Try again if no match
;Calculate number of bytes searched and return in St
Found: DEC DI ;DX = Offset where found
MOV AX,DI ;AX = Offset where found
SUB AX,BX ;Subtract starting offset
JMP Short Done ;Done
;Match was not found
Error: XOR AX,AX ;Return
DEC AX ;Return FFFF
Done: POP DS ;Restore DS
ExitCode 10
Search ENDP
CODE ENDS
END
{ END OF TPWRDSTR.ASM }
{------------------------------- CUT HERE ------------------------- }
[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]