Again,
none of this is complicated or pioneering, but each function was
designed to fill a specific need that existed at the time – one
that isn't covered by the wide range of methods provided with the
Pascal Script language library.
~
In all instances, where a call is made to a routine that is not part of the stock Pascal Script library, the listing for the routine can be found elsewhere in this or another of the "Code Bank" posts.
All references to "Common.iss" refer to the unit from which these functions are taken. Modify this in your own script to match the name of the unit in which you use it (e.g., for debugging purposes).
Stringlist
routines
//------------------------------------------------------------------------------
// Delete duplicate strings from List
//
procedure RemoveDuplicates(const List: TStringList);
var
TempList: TStringList;
i, j: Integer;
begin
if List = nil then
Exit;
TempList := TStringList.Create;
try
TempList.Sorted := True;
i := 0;
while i <= List.Count - 1 do begin
if TempList.Find(List[i], j) then
List.Delete(i)
else begin
TempList.Add(List[i]);
Inc(i, 1);
end;
end;
finally
TempList.Free;
TempList := nil;
end;
end;
//------------------------------------------------------------------------------
// Explode a delimited string (S) into a list of strings using a separator (Sep)
// (n.b., Untested)
//
procedure StrToStrings(const S, Sep: String; const List: TStringList; const AllowBlank: Boolean);
var
I, J, L, M: Integer;
Left: String;
begin
if List <> nil then
List.Clear;
if (List = nil) or (S = '') or (Sep = '') then
Exit;
L := Length(Sep);
M := Length(S);
I := 1;
J := PosEx(Sep, S, 1);
while (J > 0) do begin
Left := Copy(S, I, J - I);
if (Left <> '') or AllowBlank then
List.Add(Left);
I := J + L;
J := PosEx(Sep, S, I);
end;
if I < M then begin
Left := Copy(S, I, M - (I - 1));
if (Left <> '') or AllowBlank then
List.Add(Left);
end;
end;
String
search routines
//------------------------------------------------------------------------------
// Search for a String (Value) in an array of Strings (StrArray), return the
// array index if found, else -1
//
function StrIndex(const Value: String; const CaseSensitive: Boolean; const StrArray: array of String): Integer;
var
i, Hi, Lo: Integer;
Found: Boolean;
SearchTerm: String;
begin
Result := -1;
Lo := 0;
Hi := GetArrayLength(StrArray);
Found := False;
if not CaseSensitive then
SearchTerm := LowerCase(Value)
else
SearchTerm := Value;
for i := Lo to Hi - 1 do begin
if CaseSensitive then
Found := StrArray[i] = SearchTerm
else
Found := LowerCase(StrArray[i]) = SearchTerm;
if Found then begin
Result := i;
Break;
end;
end;
end;
//------------------------------------------------------------------------------
// Get the index of SubStr in MainStr starting from a specified offset
//
function PosEx(const SubStr, MainStr: String; Offset: Integer): Integer;
var
Loop, MStrLen, SStrLen: Integer;
TmpStr: String;
begin
Result := 0;
MStrLen := Length(MainStr);
SStrLen := Length(SubStr);
if (SubStr = '') or (MainStr = '') or (Offset <= 0) or (Offset > (MStrLen - SStrLen)) then
Exit;
if Offset = 1 then
Result := Pos(SubStr, MainStr)
else begin
Loop := Offset;
while Loop <= MStrLen do begin
if MainStr[Loop] = SubStr[1] then begin
TmpStr := Copy(MainStr, Loop, SStrLen);
if TmpStr = SubStr then begin
Result := Loop;
Break;
end;
end;
Inc(Loop, 1);
end;
end;
end;
//------------------------------------------------------------------------------
// The same as Pos, but searching begins from the right of the string, rather
// than the left e.g., calling: RPos('C', 'ABCD') will return index 3, but the
// search begins at character 'D' in the string 'ABCD' and searches towards the
// beginning of the string.
//
function RPos(const Str1, Str2: String; const CaseInsensitive: Boolean): Integer;
var
Str1Len, Str2Len: Integer;
LStr1, LStr2: String;
begin
Result := 0;
Str1Len := Length(Str1);
Str2Len := Length(Str2);
if (Str1Len = 0) or (Str2Len = 0) or (Str1Len > Str2Len) then
Exit;
LStr1 := Str1;
LStr2 := Str2;
if CaseInsensitive then begin
LStr1 := Lowercase(LStr1);
LStr2 := Lowercase(LStr2);
end;
LStr1 := ReverseString(LStr1);
LStr2 := ReverseString(LStr2);
Result := Pos(LStr1, LStr2);
if Result <> 0 then
Result := Str2Len - (Result - 1) - (Str1Len - 1);
end;
var
FTokenIndex: Integer;
FTokenString: String;
//------------------------------------------------------------------------------
// Find the first character from offset 'Start' that is NOT a blank character
//
const
TokenSeparator = ' ';
function FindNextNonBlank(const Value: String; const Start: Integer): Integer;
var
i, ValLen: Integer;
begin
Result := 0;
ValLen := Length(Value);
if (Value = '') or (Start <= 0) or (Start > ValLen) then
Exit;
i := Start;
while (i <= ValLen) and (Value[i] = TokenSeparator) do
Inc(i, 1);
if (i = ValLen) and (Value[i] = TokenSeparator) then
//
else
Result := i;
end;
//------------------------------------------------------------------------------
// Return a token from global variable 'FTokenString' - SetTokenString should be called ahead of
// this function to set the FTokenString value and reset the FTokenIndex variable.
// PeekToken does not update the FTokenIndex value
//
function PeekToken: String;
var
i, j, k: Integer;
begin
Result := '';
if FTokenString = '' then
Exit;
// Find first non-space character
i := FindNextNonBlank(FTokenString, 1);
if i <= 0 then
Exit;
// If GetToken has been called previously, get index of last token
if FTokenIndex > 0 then begin
// Shouldn't need the 'against 0' test, but just in case user changed FTokenString...
k := 0;
while (i > 0) and (k < FTokenIndex) do begin
Inc(k, 1);
i := PosEx(TokenSeparator, FTokenString, i);
if i > 0 then
i := FindNextNonBlank(FTokenString, i + 1);
end;
// Something went wrong
if k < FTokenIndex then
Exit;
end;
j := i;
if j > 0 then
Inc(j, 1);
j := PosEx(TokenSeparator, FTokenString, j);
if (j <= 0) then begin
if (i >= 1) and (i < Length(FTokenString)) then
j := Length(FTokenString) + 1
else
Exit;
end;
Result := Copy(FTokenString, i, j - i);
end;
//------------------------------------------------------------------------------
// Return a token from FTokenString - SetTokenString should be called ahead of this function to
// set the FTokenString value and reset the FTokenIndex variable.
// GetToken can be called in a loop, e.g., until GetToken returns '' (blank). GetToken increments
// FTokenIndex by '1' after each successful call (so that it can 'carry on' from where it left
// off on a subsequent call)
//
function GetToken: String;
begin
Result := PeekToken;
if Result <> '' then
Inc(FTokenIndex, 1);
end;
//------------------------------------------------------------------------------
procedure SetTokenString(const Value: String);
begin
FTokenString := Value;
FTokenIndex := 0;
end;
String
sort routines
These first six functions are a collective; this is a Pascal Script translation of a Delphi
code sample originally provided at Experts-Exchange (http://bit.ly/yKBzd8), which
implements a pure-pascal algorithm for "natural order" string sorting (comparable
to the WinAPI function StrCmpLogicalW - available with Windows XP and later). See
function descriptions below for more details
//------------------------------------------------------------------------------
// See previous "Code Bank" posting for IsDigit
//
function NonNullChar(const AChar: Char): Boolean;
begin
Result := not IsDigit(AChar) and (Ord(AChar) <> 0);
end;
//------------------------------------------------------------------------------
// Next three functions are for sorting Strings into 'natural' order, e.g.
// 1.txt, 2.txt, 3.txt, 123.txt, instead of
// 1.txt, 123.txt, 2.txt, 3.txt
//
function GetEndOfGroup(const Val: String; const Index: Integer): Integer;
var
i: Integer;
begin
Result := 0;
i := Index;
if (Length(Val) <= 0) or (i > Length(Val)) then
Exit;
if IsDigit(Val[i]) then begin
while (i <= Length(Val)) and IsDigit(Val[i]) do
Inc(i, 1);
end else begin
while (i <= Length(Val)) and (NonNullChar(Val[i])) do
Inc(i, 1);
end;
Result := i;
end;
//------------------------------------------------------------------------------
function CompareGroups(var S1Index, S2Index: Integer; const E1, E2: Integer; const S1, S2: String): Integer;
var
sTemp1, sTemp2: String;
begin
sTemp1 := Copy(S1, S1Index, E1 - S1Index);
sTemp2 := Copy(S2, S2Index, E2 - S2Index);
Result := CompareText(sTemp1, sTemp2);
S1Index := E1;
S2Index := E2;
end;
const
A1_BEFORE_A = True;
A01_BEFORE_A1 = True;
SWAP = 1;
NO_SWAP = -1;
//------------------------------------------------------------------------------
// See also, StrCmpLogicalW - WinXP+ only, but 'better' sorting, ref:
// http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_23086281.html
//
function XPSortCompareStrings(const S1, S2: String): Integer;
var
E1: Integer; // end of group in first string
E2: Integer; // end of group in second string
FallbackResult: Integer;
i, j: Integer;
begin
Result := 0;
if (Length(S1) <= 0) or (Length(S2) <= 0) then
Exit;
i := 1;
j := 1;
repeat
E1 := GetEndOfGroup(S1, i);
E2 := GetEndOfGroup(S2, j);
if (E1 = 0) then begin
if (E2 = 0) then
Break
else begin
if (A1_BEFORE_A) then
Result := SWAP
else
Result := NO_SWAP;
end;
end else begin
if (E2 = 0) then begin
if (A1_BEFORE_A) then
Result := NO_SWAP
else
Result := SWAP
end else begin
if (IsDigit(S1[i])) then
if (IsDigit(S2[j])) then begin
FallbackResult := (E2 - j) - (E1 - i);
while (S1[i] = '0') do
Inc(i, 1);
while (S2[j] = '0') do
Inc(j, 1);
Result := (E1 - i) - (E2 - j);
if (Result = 0) then
Result := CompareGroups(i, j, E1, E2, S1, S2);
if (Result = 0) then
if (A01_BEFORE_A1) then
Result := FallbackResult
else
Result := -FallbackResult;
end else
Result := NO_SWAP
else begin
if IsDigit(S2[i]) then
Result := SWAP
else
Result := CompareGroups(i, j, E1, E2, S1, S2);
end;
end;
end;
until (Result <> 0);
end;
//------------------------------------------------------------------------------
// Next two functions are for sorting a TStringList into 'natural' order
//
procedure ExchangeItems(const Index1, Index2: Integer; const List: TStringList);
var
sTemp: String;
oTemp: TObject;
begin
if not Assigned(List) or (Index1 < 0) or (Index1 > List.Count - 1) or (Index2 < 0) or (Index2 > List.Count - 1) then
Exit;
sTemp := List[Index1];
oTemp := List.Objects[Index1];
List[Index1] := List[Index2];
List.Objects[Index1] := List.Objects[Index2];
List[Index2] := sTemp;
List.Objects[Index2] := oTemp;
end;
//------------------------------------------------------------------------------
procedure QuickSort(L, R: Integer; const List: TStringList);
var
I, J, P: Integer;
begin
if (List = nil) or (L < 0) or (R > List.Count - 1) or (L > R) then
Exit;
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
while XPSortCompareStrings(List[I], List[P]) < 0 do
Inc(I, 1);
while XPSortCompareStrings(List[J], List[P]) > 0 do
Inc(J, -1);
if I <= J then begin
ExchangeItems(I, J, List);
if P = I then
P := J
else if P = J then
P := I;
Inc(I, 1);
Inc(J, -1);
end;
until I > J;
if L < J then
QuickSort(L, J, List);
L := I;
until I >= R;
end;
String
test routines
//------------------------------------------------------------------------------
// Determines whether StrA occurs at the very end of StrB
function StrEndsWith(const StrA, StrB: String): Boolean;
var
StringPos: Integer;
begin
Result := False;
StringPos := pos(StrA, StrB);
if StringPos > 0 then
Result := StringPos = Length(StrB) - (Length(StrA) - 1)
end;
//------------------------------------------------------------------------------
// Returns the length of a string less any line-break characters
function StringLength(const Value: String): Integer;
var
CRLFLen, ValLen, i: Integer;
CRLFStr: String;
begin
Result := 0;
if Value = '' then
Exit;
CRLFStr := constCRLF;
CRLFLen := Length(constCRLF);
ValLen := Length(Value);
i := 1;
Result := 0;
while i < ValLen do begin
if (Value[i] = CRLFStr[1]) and (Copy(Value, i, CRLFLen) = CRLFStr) then
Inc(i, CRLFLen)
else begin
Inc(Result, 1);
Inc(i, 1);
end;
end;
Result := Max(Result, 1);
end;
String
transformation routines
//------------------------------------------------------------------------------
// Flip the order of characters in a string
//
function ReverseString(const S: String): String;
var
I, L: Integer;
begin
L := Length(S);
SetLength(Result, L);
for I := 0 to L - 1 do
Result[L - I] := S[I + 1];
end;
const
constCRLF = #13#10;
//------------------------------------------------------------------------------
// Replace all occurrences of '%s' (string placeholder) with constCRLF
//
function CRLFFormat(const Value: String; const AddSpaces: Boolean): String;
var
TmpStr: String;
CRLFStr: String;
begin
TmpStr := Value;
CRLFStr := constCRLF;
if AddSpaces then
CRLFStr := constSP + CRLFStr + constSP;
StringChangeEx(TmpStr, '%s', CRLFStr, False);
Result := TmpStr;
end;
//-----------------------------------------------------------------------------------------------
// Append a String (StrToAdd) to another String (MainString) in a non-memory-fragmentary way (in theory)
// Note: LastRealIndex marks the last 'used' character in MainString, NOT the next free character
//
const
constStrLenIncAmount = 500;
procedure EfficientAppend(var MainString: String; var LastRealIndex: Integer; const StrToAdd: String);
var
i: Integer;
begin
if Length(StrToAdd) <= 0 then
Exit;
if Length(MainString) < constStrLenIncAmount then
SetLength(MainString, constStrLenIncAmount);
if LastRealIndex > Length(MainString) then
LastRealIndex := Length(MainString);
if (LastRealIndex + Length(StrToAdd)) > Length(MainString) then begin
if (LastRealIndex + Length(StrToAdd)) > (Length(MainString) + constStrLenIncAmount) then
SetLength(MainString, Length(MainString) + Length(StrToAdd) + constStrLenIncAmount)
else
SetLength(MainString, Length(MainString) + constStrLenIncAmount);
end;
Inc(LastRealIndex, 1);
for i := 1 to Length(StrToAdd) do begin
MainString[LastRealIndex] := StrToAdd[i];
if i < Length(StrToAdd) then
Inc(LastRealIndex, 1);
end;
end;
//-----------------------------------------------------------------------------------------------
// Concatonate a group of strings into a single string
//
function StringsToStr(const List: TStringList; const Sep: String): String;
var
i, j: Integer;
begin
Result := '';
if (List = nil) or (List.Count < 0) or (Length(Sep) <= 0) then
Exit;
j := 0;
for i := 0 to List.Count - 1 do begin
if i < List.Count - 1 then
EfficientAppend(Result, j, List[i] + Sep)
else
EfficientAppend(Result, j, List[i]);
end;
SetLength(Result, j);
end;
//-----------------------------------------------------------------------------------------------
// Format a string value so that text fits within the width of a Vista MessageDlg box (to prevent
// the OS from automatically line-breaking a string at awkward intervals). Note that any line-
// breaks already included in the text are recognised and retained, but must be separated from
// surrounding text with a space for and aft.
const
MaxVistaMsgBoxChars = 60;
function FormatStringForVistaMsgBox(const Value: String): String;
var
LValue, TempToken: String;
LValLen, PeekTokenLen: Integer;
begin
Result := '';
if Value = '' then
Exit;
SetTokenString(Value);
LValue := GetToken;
while True do begin
LValLen := StringLength(LValue);
TempToken := PeekToken;
PeekTokenLen := StringLength(TempToken);
LValLen := LValLen + PeekTokenLen;
if (LValLen > MaxVistaMsgBoxChars) or (TempToken = constCRLF) then begin
Result := Result + LValue + constCRLF;
if TempToken = constCRLF then
GetToken;
LValue := GetToken;
end else begin
if LValue <> constCRLF then
LValue := LValue + constSP;
LValue := LValue + GetToken;
end;
if PeekToken = '' then
Break;
end;
Result := Result + LValue;
end;
No comments:
Post a Comment