{$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 ------------------------- }