home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.update.uu.se
/
ftp.update.uu.se.2014.03.zip
/
ftp.update.uu.se
/
pub
/
rainbow
/
msdos
/
misc
/
messages.lzh
/
STRING.INC
< prev
Wrap
Text File
|
1984-08-31
|
22KB
|
698 lines
{ Suplementry String functions and procedures for Turbo Pascal }
(*
Written by: Tryg Helseth
Minneapolis, Minnesota
Last Revision: 1/4/85
USAGE NOTES:
The following routines provide common string functions that are
not supplied with Turbo Pascal. Many are patterned (and named)
after the General Electric Information Service COompany (GEISCO)
FORTRAN 77 string routines; others mimic SNOBOL primatives.
The general calling sequence is:
OutString := Func(InpString[,Parms])
where:
OutString = the output or target string,
Func = function name,
InpStr = Input String,
[Parms] = Additional parameter(s) used by some functions.
AVAILABLE FUNCTIONS:
LoCase Convert a single character to lower case.
LowerCase Convert a string to lower case.
UpperCase Convert a string to upper case.
TrimL Trim Left: remove leading spaces from a string.
TrimR Trim Right: remove trailing spaces from a string.
PadL Pad Left: Add leading spaces to give desired field length.
PadR Pad Right: Add trailing spaces to give desired field length.
JustL Left Justify a string within a desired field length.
JustR Right Justify a string within a desired field length.
Center Center a string within a desired field length.
GetStr Get String: Extracts a substring up to a specified delimiter.
Break Extracts a substring up to the first of several delimters.
Span Extracts a substring of delimiters up to a NON delimiter.
Note: GetStr, Span, and Break, modify the input string. The other
functions do not modify any parameters.
AVAILABLE PROCEDURES:
GString Get String: Used by Span and Break functions. It performs
both functions and allows more control by the programmer.
RealStr Convert a value of type REAL to a string representation in
any base from 2 to 36.
RealVal Convert a string representation of a number to a REAL value.
The number may be in any base from 2 to 36.
TYPE DECLARATION:
All strings are of the type, LString, which should be declared in the main
program as:
Type LString = string[n]
where n is a constant in the range of 1 to 255.
If you wish to use these functions with strings of different declared
lengths, then you must use the compiler option, {$V-}. If you choose
to do this, be sure that the defined length of LString is greater than
or equal to the longest string you will be using.
FUNCTION DECLARATIONS: *)
{===========================================}
function LoCase(InChar: char): char; forward;
{===========================================}
{
Purpose: Convert a single character to lower case.
Parameters:
Input: InChar = character to be converted.
Output: none
Function Value: LoCase = converted character.
}
{====================================================}
function LowerCase(InpStr: LString): LString; forward;
{====================================================}
{
Purpose: Convert a string of characters to lower case.
Parameters:
Input: InpStr = string to be converted.
Output: none
Function Value: LowerCase = converted string.
}
{====================================================}
function UpperCase(InpStr: LString): LString; forward;
{====================================================}
{
Purpose: Convert a string of characters to upper case.
Parameters:
Input: InpStr = string to be converted.
Output: none
Function Value: UpperCase = converted string.
}
{================================================}
function TrimL(InpStr: LString): LString; forward;
{================================================}
{
Purpose: Trim Left: Remove leading spaces from a string.
Parameters:
Input: InpStr = string to be trimmed.
Output: none
Function Value: TrimL = trimmed string.
}
{================================================}
function TrimR(InpStr: LString): LString; forward;
{================================================}
{
Purpose: Trim Right: Remove trailing spaces from a string.
Parameters:
Input: InpStr = string to be trimmed.
Output: none
Function Value: TrimR = trimmed string.
}
{==================================================================}
function PadL(InpStr: LString; FieldLen: integer): LString; forward;
{==================================================================}
{
Purpose: Pad Left: Pad a string on the left with spaces to
fill it to a desired field length. Trailing spaces
are not removed.
Parameters:
Input: InpStr = string to be padded.
Output: none
Function Value: PadL = padded string.
}
{==================================================================}
function PadR(InpStr: LString; FieldLen: integer): LString; forward;
{==================================================================}
{
Purpose: Pad Right: Pad a string on the right with spaces to
fill it to a desired field length. Leading spaces
are not removed.
Parameters:
Input: InpStr = string to be padded.
Output: none
Function Value: PadR = padded string.
}
{===================================================================}
function JustL(InpStr: LString; FieldLen: integer): LString; forward;
{===================================================================}
{
Purpose: Left justify a string within a desired field length.
First leading spaces are removed, then the string is
padded with trailing spaces to the desired length.
Parameters:
Input: InpStr = string to be justified.
Output: none
Function Value: JustL = justified string.
}
{===================================================================}
function JustR(InpStr: LString; FieldLen: integer): LString; forward;
{===================================================================}
{
Purpose: Right justify a string within a desired field length.
First trailing spaces are removed, then leading spaces
are inserted fill to the desired length.
Parameters:
Input: InpStr = string to be justified.
Output: none
Function Value: JustR = justified string.
}
{====================================================================}
function Center(InpStr: LString; FieldLen: integer): LString; forward;
{====================================================================}
{
Purpose: Center a string within a desired field length. First
the string is stripped of leading and trailing spaces,
[Only padded on left - 6/17/85 - Stew Stryker]
then the resultant string is padded equally with
leading and trailing spaces.
Parameters:
Input: InpStr = string to be justified.
Output: none
Function Value: Center = centered string.
}
{==================================================================}
function GetStr(var InpStr: LString; Delim: Char): LString; forward;
{==================================================================}
{
Purpose: Strating at the first position of the input string,
return a substring containing all characters up to
(but not including) the fisrt occurence of the given
delimiter. If the delimiter is not found, then the
entire input string is returned. The substring and
delimiter are then deleted from the input string.
Parameters:
Input: InpStr = string from which substring is removed.
Delim = delimiter to be used.
Output: InStr = remainder of input string.
Function Value: GetStr = Extracted substring.
}
{=====================================================================}
function Break(var InpStr: LString; DelStr: LString): LString; forward;
{=====================================================================}
{
Purpose: Emulates the SNOBOL BREAK function. Operation is
similar to GetStr except that several delimiters
may be used. The substring returns all characters
up to the first of any delimiter in DelStr. Unlike
GetStr, the Delimiter found is NOT removed from
the input string.
Parameters:
Input: InpStr = string from which substring is removed.
DelStr = list of delimiters.
Output: InStr = remainder of input string.
Function Value: Break = Extracted substring (Break on delimiter).
}
{====================================================================}
function Span(var InpStr: LString; DelStr: LString): LString; forward;
{====================================================================}
{
Purpose: Emulates the SNOBOL Span function. Operation is
is the reverse of Break; The input string is scanned
for characters IN DelStr. It returns a substring
containing ONLY delimiters found starting at the
first position up the the first NON delimiter. That
character is NOT removed from the input string.
Parameters:
Input: InpStr = string from which substring is removed.
DelStr = list of delimiters.
Output: InStr = remainder of input string.
Function Value: Span = Extracted substring (Span of delimiters).
}
{=======================================================================}
procedure GString(InpStr, DelStr: LString; span: boolean;
var cpos, dpos: integer; var OutStr: LString); forward;
{=======================================================================}
{
Purpose: Emulates both the SPAN and BREAK functions of SNOBOL.
SPAN: If span is true, then starting from position, cpos,
the input string is scanned for characters in the string,
DelStr. These characters are copied to the output string
until either a character NOT in DelStr is found or the end
of the string is reached. Position pointer, cpos, is reset
to point at the break character. If the end of the string
is reached, cpos is set to zero.
BREAK: If span is false, then the input string is scanned
for characters NOT in the string, DelStr. The output string
contains all characters up to the first delimiter. Position
pointer, cpos, is set to point at the delimiter found. If a
delimiter was not found, cpos is set to zero.
Dpos is set to position in DelStr of the delimiter found. If
none found, dpos is set to zero.
Parameters:
Input: InpStr = string from which subs9ring is Copied.
DelStr = delimiters to be used.
span = true = span, false = break.
cpos = starting position in input string.
Output: cpos = position past found delimiter.
dpos = which delimiter was found.
OutStr = substring copied from the input string.
}
{=================================================}
Procedure RealStr(Valu: Real; Base, Trail: integer;
var OutStr: LString); forward;
{=================================================}
{
Purpose: Convert a real value to an equivalent string representation.
The value can be represented in any base from 1 to 36 with
a specified number of digits to the right of the radix point.
Digits 10 thru 35 are represeted by the letters A thru Z.
Parameters:
Input: Valu = Real value to be converted to a string.
Base = Desired base.
Trail = number of digits to the right of the radix point.
Output: OutStr = string representation.
}
{===========================================================}
Procedure RealVal(InpStr: LString; Base: integer;
Var Err: integer; Var Valu: real); forward;
{===========================================================}
{
Purpose: Convert a string representation of a number to a real value.
The value can be represented in any base from 1 to 36 and
can have a fractional part. Digits 10 thru 35 are represeted
by the letters A thru Z respectively. If an illegal
character is encounterd, conversion halts and the error
postion is reported through the variable, Err.
Parameters:
Input: InpStr = String representation to be converted to a real value.
Base = Base the value is represented in.
Output: Err = position of illegial character; set to zero
if no error is encountered.
Valu = converted value.
}
{
FUNCTION BODIES:
}
{==============}
function LoCase;
{==============}
{ convert a character to lower case }
begin
if InChar IN ['A'..'Z'] then
LoCase := Chr(Ord(Inchar)+32)
else
LoCase := InChar
end;
{=================}
function LowerCase;
{=================}
{ convert a string to lower case characters }
var i : integer;
begin
for i := 1 to Length(InpStr) do
LowerCase[i] := LoCase(InpStr[i]);
LowerCase[0] := InpStr[0]
end;
{=================}
function UpperCase;
{=================}
{ convert a string to upper case characters }
var i : integer;
begin
for i := 1 to Length(InpStr) do
UpperCase[i] := UpCase(InpStr[i]);
UpperCase[0] := InpStr[0]
end;
{=============}
function TrimL;
{=============}
{ strip leading spaces from a string }
var i,len : integer;
begin
len := length(InpStr);
i := 1;
while (i <= len) and (InpStr[i] = ' ') do
i := i + 1;
TrimL := Copy(InpStr,i,len-i+1)
end;
{=============}
function TrimR;
{=============}
{ strip trailing spaces from a string }
var i : integer;
begin
i := length(InpStr);
while (i >= 1) and (InpStr[i] = ' ') do
i := i - 1;
TrimR := Copy(InpStr,1,i)
end;
{============}
function PadL;
{============}
{ Pad string on left with spaces to fill to the desired field length }
var STemp : LString;
i : integer;
begin
If FieldLen >= SizeOF(InpStr) then FieldLen := SizeOf(InpStr)-1;
if length(InpStr) > FieldLen then
PadL := Copy(InpStr,1,FieldLen)
else begin
STemp := InpStr;
for i := Length(STemp)+1 to FieldLen do
Insert(' ',STemp,1);
PadL := STemp
end
end;
{============}
function PadR;
{============}
{ Pad string on right with spaces to fill to the desired field length }
var STemp : LString;
i : integer;
begin
If FieldLen >= SizeOF(InpStr) then FieldLen := SizeOf(InpStr)-1;
if length(InpStr) > FieldLen then
PadR := Copy(InpStr,1,FieldLen)
else begin
STemp := InpStr;
for i := Length(STemp)+1 to FieldLen do
STemp := STemp + ' ';
PadR := STemp
end
end;
{=============}
function JustL;
{=============}
{ Left justify the string within the given field length }
begin
JustL := PadR(TrimL(InpStr),FieldLen)
end;
{=============}
function JustR;
{=============}
{ Right justify the string within the given field length }
begin
JustR := PadL(TrimR(InpStr),FieldLen)
end;
{==============}
function Center;
{==============}
{ Center a string within a specified field length; the string
is padded on both sides with spaces }
var LeadSpaces : integer;
STemp : LString;
begin
{ strip leading and trailing spaces; determine the
Number of spaces needed to center the string }
STemp := TrimR(TrimL(InpStr));
LeadSpaces := (FieldLen - Length(STemp) + 1) div 2;
{ insert leading spaces then trailing spaces }
Center := PadL(STemp,FieldLen-LeadSpaces)
end;
{==============}
function GetStr;
{==============}
{ Return a string containing all characters starting at the
first position of the source string up to the first delimiter.
}
var i : integer;
begin
i := Pos(Delim,InpStr);
if i = 0 then begin
GetStr := InpStr;
InpStr := ''
end
else begin
GetStr := Copy(InpStr,1,i-1);
Delete(InpStr,1,i)
end
end;
{=============}
function Break;
{=============}
{ Emulate SNOBOL BREAK function }
var cp, dp : integer;
OutStr : LString;
begin
cp := 1;
GString(InpStr,DelStr,false,cp,dp,OutStr);
Break := OutStr;
if cp = 0 then
InpStr := ''
else
Delete(InpStr,1,cp-1)
end;
{============}
function Span;
{============}
{ Emulate SNOBOL SPAN function }
var cp, dp : integer;
OutStr : LString;
begin
cp := 1;
GString(InpStr,DelStr,true,cp,dp,OutStr);
Span := OutStr;
if cp = 0 then
InpStr := ''
else
Delete(InpStr,1,cp-1)
end;
{================}
procedure GString;
{================}
{ Return a string containing all characters starting at position, cpos,
of the source string up to the first first occurence of any of several
delimiters. The position of the found delimiter is returned as well
as which delimiter.
}
var done : boolean;
begin
OutStr := ''; dpos := 0;
if cpos > 0 then begin
done := false;
while (cpos <= Length(InpStr)) and not done do begin
dpos := pos(InpStr[cpos],DelStr);
if span xor (dpos = 0) then begin
OutStr := OutStr + InpStr[cpos];
cpos := cpos + 1
end
else
done := true
end;
if (span xor (dpos = 0)) or (cpos > length(InpStr)) then cpos := 0
end
end;
{================}
procedure RealStr;
{================}
{ Convert a real value to a string }
var i, digit, MaxLen : integer;
IntValu, FracValu : real;
Sign : boolean;
{-----------------------------------}
function NewDigit(num:integer): char;
{-----------------------------------}
begin
if num < 10 then
NewDigit := chr(num + ord('0'))
else
NewDigit := chr(num + ord('A') - 10)
end;
begin
MaxLen := SizeOf(OutStr);
if Valu < 0 then begin
Valu := - Valu;
Sign := true
end
else
Sign := false;
IntValu := Int(Valu);
FracValu := Frac(Valu);
if Valu < 1 then
OutStr := '0'
else begin
{ convert Leading digits to a string }
OutStr := '';
While (IntValu >= 1) and (Length(OutStr) < MaxLen) do begin
Valu := IntValu / Base;
Digit := Trunc(Round(Frac(Valu)*Base));
IntValu := Int(Valu);
Insert(NewDigit(digit),OutStr,1);
end
end;
if (Trail > 0) and ( length(OutStr) < MaxLen) then begin
{ convert trialing digits }
OutStr := OutStr + '.';
i := 1;
While (Length(OutStr) < MaxLen) and (i <= Trail) do begin
Valu := FracValu * Base;
Digit := Trunc(Valu);
FracValu := Frac(Valu);
OutStr := OutStr + NewDigit(Digit);
i := i + 1
end
end;
if sign then Insert('-',OutStr,1);
end;
{================}
procedure RealVal;
{================}
{ convert a string to a real value }
var i, digit : integer;
GotRadixPoint,
GotDigit,Negate : boolean;
InChar : char;
InvBase : real;
begin
Valu := 0; Err := 0; negate := false; i := 0;
InvBase := 1; GotRadixPoint := false;
while (i < length(InpStr)) and (err = 0) do begin
i := i + 1;
GotDigit := false;
InChar := UpCase(InpStr[i]);
case InChar of
'0'..'9': begin
digit := ord(InpStr[i]) - ord('0');
GotDigit := true
end;
'A'..'Z': begin
digit := ord(InChar) - ord('A') + 10;
GotDigit := true
end;
'-' : begin
if negate then
err := i
else
negate := true
end;
'+' : if negate then err := i;
'.' : if GotRadixPoint then
err := i
else
GotRadixPoint := true;
else err := i
end {case} ;
if GotDigit then
if digit >= base then
err := i
else
if GotRadixPoint then begin
InvBase := InvBase / base;
Valu := Valu + InvBase * digit
end
else
Valu := Valu * base + digit
end; { while }
if negate then valu := - valu;
end;