Snippets for the code bank pt. 2

A follow-up to last months post (“Snippets for the code bank” @ http://bit.ly/xwIV51), below is an assortment of functions and definitions from my Inno Setup/Rem Objects Pascal Script grab-bag. Some of them are inter-dependent, so it's important to be aware that because none are member methods, where Function A is used by Function B, Function A must be declared first.

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;

Snippets for the code bank

Quick re-cap from previous posts: Inno Setup is an open-source, freeware “installation builder”. It's an application for creating “installers” for other applications. Though it can be just as usefully employed for adding files of any variety to a Windows PC.

   
~

Specifying which files or directories to copy to, update, or create on the target PC is as easy as listing the appropriate paths in an Inno Setup script. But if you want to define more detailed custom actions, eventually you'll want to take a look at the scripting capabilities that are built into the Inno Setup development environment.

If you recall, Inno Setup uses Pascal Script as its lingua franca for coding duties (also available for free with full source code as a stand-alone download from software developer Rem Objects). And also that Pascal Script is a fully-featured implementation of the Pascal programming language, with most of the classes and functions available from the world of its binary-compiled big brothers, like Delphi.

Inno Setup comes supplied with a host of code samples for common scripting tasks, and the Help file is another useful source of worked examples. You can also find Pascal Script documentation on the Rem Objects website, and there are several other enthusiast sites that carry extra useful code listings and libraries – most notably the InnoSetup Extensions Knowledgebase.

But I've amassed quite a collection of little functions and procedures of my own over time, and so I'll be adding some of them here and in subsequent posts as they come to light (I'll be dredging through past projects to haul them out for public consumption/ridicule).

Many of these are trivially simple, but you plug the holes where you finds 'em. Lots more to come.

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).

Boolean routines

//------------------------------------------------------------------------------
// Convert a Boolean value to a String
//
function BoolToStr(const Value: Boolean): String;
begin
  Result := 'True';
  if not Value then
    Result := 'False';
end;

//------------------------------------------------------------------------------
// Convert a String to a Boolean (see previous Code Bank post for StrIndex)
//
function StrToBool(const Value: String): Boolean;
begin
  if StrIndex(Value, False, ['true', 't', '1', 'yes', 'y']) >= 0 then
    Result := True
  else if StrIndex(Value, False, ['false', 'f', '0', 'no', 'n']) >= 0 then
    Result := False
  else
    RaiseException('Invalid String/Boolean representation');
end;

Character test routines

//------------------------------------------------------------------------------
// Returns True if "AChar", a single character, is a number
//
function IsDigit(const AChar: Char): Boolean;
begin
  Result := (Ord(AChar) >= 48) and (Ord(AChar) <= 57);
end;

//------------------------------------------------------------------------------
// Returns True if "AChar", a single character, is a letter
// n.b., Roman/Latin alphabet only!
//
function IsAlpha(const AChar: Char): Boolean;
begin
  Result := ((Ord(AChar) >= 65) and (Ord(AChar) <= 90)) or ((Ord(AChar) >= 97) and (Ord(AChar) <= 122));
end;

Debug routines

//------------------------------------------------------------------------------
// Show a message if 'DebugMode' is active
//
procedure DebugMsg(const UnitName, MethodName, LineNo, Msg: String);
var
  MsgOut: String;
begin
  if FDebugMode then begin
    MsgOut := 'Unit: ' + UnitName + #13 + 'Method: ' + MethodName + #13 + 'Line number: ' + LineNo + #13 + 'Message: ' + Msg;
    MsgBox(MsgOut, mbInformation, MB_OK);
  end;
end;

var
  FDebugMode: Boolean;

//------------------------------------------------------------------------------
// Sets global variable "FDebugMode" to True if a parameter is passed to Setup
// from the command line in the forum "/debug=true"
//
procedure CheckForDebugMode;
var
  About: String;
begin
  // Show Debug messages?
  FDebugMode := ExpandConstant('{param:debug|false}') = 'true';
  if FDebugMode then
    DebugMsg('Common.iss', 'CheckForDebugMode', '-1', 'Debug mode enabled');
  else
    DebugMsg('Common.iss', 'CheckForDebugMode', '-1', 'Debug mode NOT enabled');
end;

Math routines

//------------------------------------------------------------------------------
// Silly-simple implementation of the Delphi 'Inc' function - just adds 'Amount'
// to a passed in value
//
procedure Inc(var Value: Integer; const Amount: Integer);
begin
  Value := Value + Amount;
end;

//------------------------------------------------------------------------------
// Compare two Integers, return the higher
//
function Max(const Value1, Value2: Integer): Integer;
begin
  Result := Value1;
  if Value2 > Value1 then
    Result := Value2;
end;

//------------------------------------------------------------------------------
// Compare two Integers, return the lower
//
function Min(const Value1, Value2: Integer): Integer;
begin
  Result := Value1;
  if Value2 < Value1 then
    Result := Value2;
end;

Registry routines

//------------------------------------------------------------------------------
// Extract a value from the Registry
// This function specifically deals with values stored under the "Uninstall" key
// entry created by an Inno Setup installer. This includes useful information
// such as the "DisplayName", "InstallDate" and "InstallLocation" - the folder to
// which the application was copied.
//
function GetRegistryKeyValue(const KeyValueName, AppName: String; var FoundValue: String): Boolean;
var
  RootKeyName: Integer;
  SubKeyName, ValueName: String;
begin
  Result := False;
  FoundValue := '';
  
  RootKeyName := HKEY_LOCAL_MACHINE;
  SubKeyName  := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\' + AppName + '_is1';
  ValueName   := KeyValueName;
  try
    Result := RegQueryStringValue(RootKeyName, SubKeyName, ValueName, FoundValue);
  except
  end;
end;

ActiveX routines

type
  TMSXMLVersion = (msxOne, msxTwo, msxThree, msxFour, msxFive, msxSix);

const
  MSXMLOneProgID   = 'MSXML.DOMFreeThreadedDocument';
  MSXMLTwoProgID   = 'MSXML.DOMDocument';
  MSXMLThreeProgID = 'MSXML2.DOMDocument';
  MSXMLFourProgID  = 'Msxml2.DOMDocument.4.0';
  MSXMLFiveProgID  = 'Msxml2.DOMDocument.5.0';
  MSXMLSixProgID   = 'Msxml2.DOMDocument.6.0';

//------------------------------------------------------------------------------
// Generic method for assessing success in attempts to create a named OLE object class
function OLEObjectTest(const ClassName: String): Boolean;
begin
  Result := False;
  try
    CreateOLEObject(ClassName);
    Result := True;
  except
  end;
end;

//------------------------------------------------------------------------------
// Test whether a given MSXML version is installed: note, later versions are backward-compatible,
// so a later revision implies the availability of functionality in an earlier edition
function MSXMLVerInstalled(const Version: TMSXMLVersion): Boolean;
begin
  Result := OLEObjectTest(MSXMLSixProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxSix)));
  if (Result) or (not Result and (Integer(Version) = Integer(MemberToMSXMLVersion(msxSix)))) then
    Exit;
  Result := OLEObjectTest(MSXMLFiveProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxFive)));
  if (Result) or (not Result and (Integer(Version) = Integer(MemberToMSXMLVersion(msxFive)))) then
    Exit;
  Result := OLEObjectTest(MSXMLFourProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxFour)));
  if (Result) or (not Result and (Integer(Version) = Integer(MemberToMSXMLVersion(msxFour)))) then
    Exit;
  Result := OLEObjectTest(MSXMLThreeProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxThree)));
  if (Result) or (not Result and (Integer(Version) = Integer(MemberToMSXMLVersion(msxThree)))) then
    Exit;
  Result := OLEObjectTest(MSXMLTwoProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxTwo)));
  if (Result) or (not Result and (Integer(Version) = Integer(MemberToMSXMLVersion(msxTwo)))) then
    Exit;
  Result := OLEObjectTest(MSXMLOneProgID) and (Integer(Version) <= Integer(MemberToMSXMLVersion(msxOne)));
end;

System routines

// These record types, the DLL function prototypes and the GetNativeSystemInfo,
// CharArrayToString and GetWindowsVersion functions are all related.
// The function of interest here is "GetWindowsVersion" (the others are all
// helpers); this is copied from the JEDI JCL JCLSysInto.pas unit, and modified
// for Pascal Script compatibility.
// When called it returns an enumerated value representing the version of Windows
// reported by the operating system - wvWin95 for Windows 95, wvWin2000 for Windows
// 2000 and so on.
//
type
  TOSVersionInfoExA = record
    dwOSVersionInfoSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformId: DWORD;
    szCSDVersion: array [0..127] of Char;  
    wServicePackMajor: WORD;
    wServicePackMinor: WORD;
    wSuiteMask: WORD;
    wProductType: BYTE;
    wReserved: BYTE;
  end;

  TSystemInfo = record
    wProcessorArchitecture: Word;
    wReserved: Word;
    dwPageSize: DWORD;
    lpMinimumApplicationAddress: Integer;
    lpMaximumApplicationAddress: Integer;
    dwActiveProcessorMask: DWORD;
    dwNumberOfProcessors: DWORD;
    dwProcessorType: DWORD;
    dwAllocationGranularity: DWORD;
    wProcessorLevel: Word;
    wProcessorRevision: Word;
  end;

  TCharArray = array of Char;

  TWinVersion = (wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE, wvWinME,
    wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4, wvWin2000, wvWinXP,
    wvWin2003, wvWinXP64, wvWin2003R2, wvWinVista, wvWinServer2008,
    wvWin7, wvWinServer2008R2);

function DLL_GetVersionEx(var VersionInformation: TOSVersionInfoExA): Integer;
external 'GetVersionExA@kernel32.dll stdcall';  

procedure DLL_GetNativeSystemInfo(var SystemInfo: TSystemInfo);
external 'GetNativeSystemInfo@kernel32.dll stdcall delayload';

procedure DLL_GetSystemInfo(var SystemInfo: TSystemInfo); 
external 'GetSystemInfo@kernel32.dll stdcall delayload';

function GetSystemMetrics(nIndex: Integer): Integer; 
external 'GetSystemMetrics@user32.dll stdcall';

//------------------------------------------------------------------------------
function GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean;
var
  SysInfo: TSystemInfo;
begin
  Result := False;

  SysInfo.wProcessorArchitecture := 0;
  SysInfo.wReserved := 0;
  try    
    DLL_GetNativeSystemInfo(SysInfo);
  except
    // GetNativeSystemInfo is only available in Window XP and later - so trying to 
    // call the function will fail on earlier OS'.
    // Note that WE only use it to distinguish between XP and 2003, so this shouldn't 
    // be an issue, but if this function were ever needed elsewhere... 
    // Note also that GetSystemInfo is NOT available on Windows 95
    DLL_GetSystemInfo(SysInfo);
  end;
end;

//------------------------------------------------------------------------------
function CharArrayToString(const CharArray: TCharArray): String;
var
  i: Integer;
begin
  SetLength(Result, GetArrayLength(CharArray));
  for i := 1 to Length(Result) do
    Result[i] := CharArray[i - 1];
end;

//------------------------------------------------------------------------------
const
  PROCESSOR_ARCHITECTURE_INTEL = 0;
  VER_PLATFORM_WIN32_WINDOWS   = 1;
  VER_PLATFORM_WIN32_NT        = 2;
  SM_SERVERR2                  = 89;

function GetWindowsVersion: TWinVersion;
var
  TrimmedWin32CSDVersion: string;
  OSVersionInfoExA: TOSVersionInfoExA;
  SystemInfo: TSystemInfo;
  KernelVersionHi: Cardinal;
  KernelDLLPath: String;
  VersionMS, VersionLS: Cardinal;
begin
  Result := wvUnknown;
  OSVersionInfoExA.dwOSVersionInfoSize := SizeOf(OSVersionInfoExA);
  DLL_GetVersionEx(OSVersionInfoExA);
  TrimmedWin32CSDVersion := CharArrayToString(OSVersionInfoExA.szCSDVersion);
  TrimmedWin32CSDVersion := Trim(TrimmedWin32CSDVersion);
  KernelDLLPath := AddBackslash(GetSystemDir) + 'kernel32.dll';
  GetVersionNumbers(KernelDLLPath, VersionMS, VersionLS); 

  case OSVersionInfoExA.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS:
      case OSVersionInfoExA.dwMinorVersion of
        0, 1, 2, 3, 4, 5, 6, 7, 8, 9:
          if (TrimmedWin32CSDVersion = 'B') or (TrimmedWin32CSDVersion = 'C') then
            Result := wvWin95OSR2
          else
            Result := wvWin95;
        10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 
        31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51,
        52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72,
        73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89:
          // On Windows ME Win32MinorVersion can be 10 (indicating Windows 98
          // under certain circumstances (image name is setup.exe). Checking
          // the kernel version is one way of working around that.
          if VersionMS = $0004005A then // 4.90.x.x
            Result := wvWinME
          else
          if (TrimmedWin32CSDVersion = 'A') or (TrimmedWin32CSDVersion = 'B') then
            Result := wvWin98SE
          else
            Result := wvWin98;
        90:
          Result := wvWinME;
      end;
    VER_PLATFORM_WIN32_NT:
      case OSVersionInfoExA.dwMajorVersion of
        3:
          case OSVersionInfoExA.dwMinorVersion of
            1:
              Result := wvWinNT31;
            5:
              Result := wvWinNT35;
            51:
              Result := wvWinNT351;
          end;
        4:
          Result := wvWinNT4;
        5:
          case OSVersionInfoExA.dwMinorVersion of
            0:
              Result := wvWin2000;
            1:
              Result := wvWinXP;
            2:
              begin
                OSVersionInfoExA.dwOSVersionInfoSize := SizeOf(OSVersionInfoExA);
                SystemInfo.wProcessorArchitecture := 0;
                SystemInfo.wReserved := 0;
                GetNativeSystemInfo(SystemInfo);
                if GetSystemMetrics(SM_SERVERR2) <> 0 then
                  Result := wvWin2003R2
                else if (SystemInfo.wProcessorArchitecture <> PROCESSOR_ARCHITECTURE_INTEL) and (DLL_GetVersionEx(OSVersionInfoExA) <> 0) and (OSVersionInfoExA.wProductType = VER_NT_WORKSTATION) then
                  Result := wvWinXP64
                else
                  Result := wvWin2003;
              end;
          end;
        6:
          case OSVersionInfoExA.dwMinorVersion of
            0:
              begin
                OSVersionInfoExA.dwOSVersionInfoSize := SizeOf(OSVersionInfoExA);
                if (DLL_GetVersionEx(OSVersionInfoExA) <> 0) and (OSVersionInfoExA.wProductType = VER_NT_WORKSTATION) then
                  Result := wvWinVista
                else
                  Result := wvWinServer2008;
              end;
            1:
              begin
                OSVersionInfoExA.dwOSVersionInfoSize := SizeOf(OSVersionInfoExA);
                if (DLL_GetVersionEx(OSVersionInfoExA) <> 0) and (OSVersionInfoExA.wProductType = VER_NT_WORKSTATION) then
                  Result := wvWin7
                else
                  Result := wvWinServer2008R2;
              end;
          end;
      end;
  end;
end;

//------------------------------------------------------------------------------
// Pascal Script doesn't like casting from an enumerated member to Integer, but will allow casting
// from an anonymous enumerated value to Integer
//
function MemberToMSXMLVersion(const Value: TMSXMLVersion): TMSXMLVersion;
begin
  Result := Value;
end;

//------------------------------------------------------------------------------
function MemberToWinVersion(const Value: TWinVersion): TWinVersion;
begin
  Result := Value;
end;

//------------------------------------------------------------------------------
// Returns TRUE if the version of Windows reported by the OS matches one of the
// values in the "WinVersionSet" set, e.g., if the installer is running on Windows
// 2000, and "WinVersionSet" contains [wvWin98, wvWin98SE, wvWinME, wvWin2000] then
// the function would return TRUE.
//
function IsGivenWindowsVersion(const WinVersionSet: TWinVersionSet): Boolean;
begin
  Result := GetWindowsVersion in WinVersionSet;
end;

//------------------------------------------------------------------------------
// Returns TRUE if the version of Windows reported by the OS is the same as or
// later (more recent) than the value passed in through "WinVersion".
// e.g., if the installer is running on Windows 2000, and "WinVersion" contains
// wvWinXP, the function would return TRUE.
//
function IsGivenWindowsVersionOrLater(const WinVersion: TWinVersion): Boolean;
var
  ActualOSVer, TargetOSVer: Integer;
begin
  ActualOSVer := Integer(GetWindowsVersion);
  TargetOSVer := Integer(MemberToWinVersion(WinVersion));
  Result := ActualOSVer >= TargetOSVer;
end;

//------------------------------------------------------------------------------
// Returns TRUE if the version of Windows reported by the OS is the same as or
// earlier than the value passed in through "WinVersion".
// e.g., if the installer is running on Windows 2000, and "WinVersion" contains
// wvWin98, the function would return TRUE.
//
function IsGivenWindowsVersionOrEarlier(const WinVersion: TWinVersion): Boolean;
var
  ActualOSVer, TargetOSVer: Integer;
begin
  ActualOSVer := Integer(GetWindowsVersion);
  TargetOSVer := Integer(MemberToWinVersion(WinVersion));
  Result := ActualOSVer <= TargetOSVer;
end;

//------------------------------------------------------------------------------
// Returns True if: 1) the operating system is Windows 95; 2) no web-browser is installed
//
function IsBrowserlessOS: Boolean;
var
  sVersion: String;
begin
  try
    sVersion := '';
    RegQueryStringValue(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Internet Explorer', 'Version', sVersion);
  except
  end;
  Result := (sVersion = '') and (GetWindowsVersion = wvWin95);
end;

//------------------------------------------------------------------------------
// Unregister a DLL file, displaying an error message if procedure fails
//
function UnregisterDLL(const FileName: String): Boolean;
var
  DLLLongName, DLLShortName: String;
  SUnRegOK, LUnRegOK: Boolean;
begin
  DLLLongName  := GetLongName(FileName);
  DLLShortName := GetShortNameEx(FileName);

  if not FileExists(FileName) then begin
    DebugMsg('Common.iss', 'UnregisterDLL', '-1', 'DLL file not found: ' + FileName);
    Exit;
  end;

  SUnRegOK := UnRegisterServer(Is64BitInstallMode, DLLShortName, False);
  if not SUnRegOK then
    LUnRegOK := UnRegisterServer(Is64BitInstallMode, DLLLongName, False);
  Result := SUnRegOK or LUnRegOK;
  if not Result then
    MsgBox(FormatStringForVistaMsgBox(CRLFFormat('{#AppUnregisterDLLError}', True)) + FileName, mbError, MB_OK);
end;

File routines

//------------------------------------------------------------------------------
// Remove the final file extension part from a file path
// e.g., "test.txt" becomes "test"
//
function TrimFileExt(const FileName: String): String;
var
  FileExt: String;
  i: Integer;
begin
  Result := FileName;
  if Length(FileName) > 0 then begin
    FileExt := ExtractFileExt(FileName);
    i := Length(FileExt);
    if i > 0 then begin
      if i < Length(FileName) then
        Result := Copy(FileName, 1, Length(FileName) - i)
      else
        Result := '';
    end;
  end;
end;

//------------------------------------------------------------------------------
// "ADir" is a file path - the Result is the parent directory of this path
// e.g., "C:\Temp\Test" becomes "C:\Temp"
//
function UpOneDirectory(const ADir: String): String;
var
  SlashPos: Integer;
begin
  Result := ADir;
  if (Result = '') or (IsDriveRoot(ADir)) then
    Exit;

  if Result[Length(Result)] = '\' then
    Result := RemoveBackslash(Result)
  else
    Result := Copy(Result, 1, RPos('\', Result, False) - 1);

  SlashPos := RPos('\', Result, False);
  Result := Copy(Result, 1, SlashPos);
end;

//------------------------------------------------------------------------------
// Returns True if "ADir" represents the "root" of a drive
// "C:" returns True
// "C:\" returns True
// "C:\test" returns False
//
function IsDriveRoot(const ADir: String): Boolean;
var
  Drive, DriveAndPath: String;
begin
  // UNC/drive letter root?
  Drive := ExtractFileDrive(ADir);    // Returns 'C:' or '\\server\share'
  DriveAndPath := Drive;
  if Drive <> '' then
    DriveAndPath := AddBackslash(Drive);

  Result := (ADir = Drive) or (ADir = DriveAndPath);
end;

//------------------------------------------------------------------------------
// Enumerates files in a named directory, and saves the results in a passed-in
// StringList
//
procedure EnumDirFiles(const FileList: TStringList; const Directory: String; const ClearList: Boolean);
var
  PathD: String;
  FileD: String;
  FindRec: TFindRec;
begin
  if (FileList <> nil) and (ClearList) then
    FileList.Clear;

  if (FileList = nil) or not DirExists(Directory) then
    Exit;

  PathD := AddBackslash(Directory)
  if FindFirst(PathD + '*.*', FindRec) then begin
    try
      repeat
        // Only add files, not directories
        if FindRec.Attributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin  
          // We found one file that matches our wildcards
          // FindFirst returns the name of the file with no path so must account for that
          FileD := PathD + FindRec.Name
          if FileExists(FileD) then
            FileList.Add(FileD);
        end;
      until not FindNext(FindRec);
    finally
      FindClose(FindRec);
    end;
  end;
end;

//------------------------------------------------------------------------------
// Enumerates all sub-directories in a named directory (StartDir), and all child
// directories of those directories - and so on - until all directories in the
// hierarchy added to DirList
//
procedure EnumDirectories(const DirList: TStringList; const StartDir: String; const ClearList: Boolean);
var
  PathD: String;
  FindRec: TFindRec;
  Index, Count: Integer;
begin
  if (DirList <> nil) and (ClearList) then
    DirList.Clear;

  if (DirList = nil) or not DirExists(StartDir) then
    Exit;

  DirList.Add(AddBackslash(StartDir));
  Index := 0;
  try
    repeat
      PathD := DirList[Index];
      Count := 0;
      if FindFirst(PathD + '*.*', FindRec) then begin
        repeat
          // Only add directories - and don't RE-add the name of the directory we're searching through (e.g., when Count = 0)
          if (FindRec.Attributes and FILE_ATTRIBUTE_DIRECTORY <> 0) and (Count > 0) and (FindRec.Name <> '.') and (FindRec.Name <> '..') then
            // Find* returns names without path parts so we must account for that
            DirList.Add(AddBackslash(PathD + FindRec.Name));
          Inc(Count, 1);
        until not FindNext(FindRec);
      end;
      Inc(Index, 1);
    until Index > DirList.Count - 1;
  finally
    FindClose(FindRec);
  end;
end;

//------------------------------------------------------------------------------
// Pascal Script version of JCLFileUtils function of same name - find a file name
// that does not correspond to any existing file.
// If 'Simple' is true, returns the first available free name in a numbered
// sequence, e.g., if:
// test0.txt, test1.txt, test3.txt exist, would return test2.txt
// If 'Simple' is false, returns the the next available free name beyond the last
// existing name in a numbered sequence, e.g., if:
// test0.txt, test1.txt, test3.txt exist, would return test4.txt
//
function FindUnusedFileName(const FileName, FileExt, Suffix: String; const Simple: Boolean): String;
var
  I: Integer;
  TempString, NoSuffix, sSuffix: String;
  iSuffix: Integer;
begin
  I := 0;
  if Simple then begin
    Result := FileName + '.' + FileExt;

    while FileExists(Result) do begin
      Result := FileName + Suffix + IntToStr(I) + '.' + FileExt;
      Inc(I, 1);
    end;
  end else begin
    TempString := GetMostRecentBackup(FileName + Suffix + '.' + FileExt);
    if CompareText(TempString, FileName + Suffix + '.' + FileExt) = 0 then
      Result := FileName + Suffix + IntToStr(I) + '.' + FileExt
    else begin
      NoSuffix := StripSuffix(TempString, sSuffix);
      iSuffix := StrToIntDef(sSuffix, -1);
      if iSuffix < 0 then begin
        if FDebugMode then
          Log('Common.iss->FindUnusedFileName->NonSimple->Error extracting suffix from filename: ' + TempString);
        iSuffix := 0;
      end;
      Inc(iSuffix, 1);
      Result := FileName + Suffix + IntToStr(iSuffix) + '.' + FileExt;
    end;
  end;
end;

//------------------------------------------------------------------------------
function GetAllUsersAppDataFolder(Param: String): String;
var
  WinVer: TWinVersion;
begin
  Result := '';
  WinVer := GetFriendlyWindowsVersion;

  // Windows 95: 
  // Windows 98/ME: C:\Program Files\Common Files
  // WindowsNT: C:\WINNT\Profiles\All Users\Application Data
  // Windows2000/XP: C:\Documents and Settings\All Users\Application Data
  case WinVer of
    wvWin95, wvWin95OSR2, wvWin98, wvWin98SE, wvWinME: Result := ExpandConstant('{cf}');
    wvWinNT31, wvWinNT35, wvWinNT351, wvWin2000, wvWinXP, wvWin2003, wvWinXP64, wvWin2003R2, wvWinVista, wvWinServer2008, wvWin7, wvWinServer2008R2: Result := ExpandConstant('{commonappdata}');
  end;

  DebugMsg('Common.iss', 'GetAllUsersAppDataFolder', '-1', 'All Users Application Data folder determined to be: ' + Result);
end;

//------------------------------------------------------------------------------
// Copied from JEDI JCLFileUtils.pas PathGetLongName2 (with some small modifications to make it
// PascalScript compatible)
//
function GetLongName(const Path: String): String;
var
  LPath: String;
  I: Integer;
  FindData: TFindRec;
  IsBackSlash: Boolean;
begin
  LPath := ExpandFileName(Path);
  Result := ExtractFileDrive(LPath);
  i := Length(Result);
  if Length(LPath) <= i then
    Exit;   // only drive
  if LPath[i + 1] = '\' then begin
    Result := AddBackslash(Result);
    Inc(i, 1);
  end;
  Delete(LPath, 1, i);
  repeat
    i := Pos('\', LPath);
    IsBackSlash := i > 0;
    if not IsBackSlash then
      i := Length(LPath) + 1;
    if FindFirst(Result + Copy(LPath, 1, i - 1), FindData) then begin
      try
        Result := Result + FindData.Name;
        if IsBackSlash then
          Result := AddBackslash(Result);
      finally
        FindClose(FindData);
      end;
    end else begin
      Result := Result + LPath;
      Break;
    end;
    Delete(LPath, 1, i);
  until Length(LPath) = 0;
end;

//------------------------------------------------------------------------------
function GetShortNameEx(const Path: String): String;
var
  TempFile: String;
  TempFileShort: String;
begin
  Result := Path;

  TempFile := AddBackslash(GetTempDir) + ExtractFileName(Path);
  if not FileExists(TempFile) then
    if not SaveStringToFile(TempFile, '', False) then
      Exit;

  TempFileShort := GetShortName(TempFile);
  Result := AddBackslash(GetShortName(ExtractFilePath(Path))) + ExtractFileName(TempFileShort);
  DeleteFile(TempFile);
end;

//------------------------------------------------------------------------------
// Retrieve the registry-stored location of the directory within which the name application resides
//
const
  scInstallLocation = 'InstallLocation';

function GetAppInstallDir(const AppName: String): String;
var
  AppPath: String;
  KeyName: String;
begin
  Result := '';
  KeyName := AppName;

  if not GetRegistryKeyValue(scInstallLocation, KeyName, AppPath) then
    RaiseException('Error retrieving ' + AppName + ' install location from registry: Common.iss->GetAppInstallDir');
  Result := AddBackslash(AppPath);
  DebugMsg('Common.iss', 'GetAppInstallDir', '-1', 'App install directory determined to be: ' + Result);
end;

//------------------------------------------------------------------------------
// Return an appropriate Help File name (personal convention means that a Help File is always
// labelled 'HelpFile' (to make its purpose obvious); where Internet Explorer is available on the
// client PC, add a 'CHM' extension. Where Internet Explorer is unavailable, fall-back to WinHelp
// and add a 'HLP' file extension
//
const
  scCHM          = 'chm';
  scHLP          = 'hlp';
  scHelpFileName = 'HelpFile';
  
function GetHelpFileName(Param: String): String;
var
  sVersion: String;
  RegLookupOK: Boolean;
begin
  // Default to Compiled HTML HelpFile name
  Result := scHelpFileName + '.' + scCHM;
  RegLookupOK := False;
  try
    sVersion := '';
    RegLookupOK := RegQueryStringValue(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Internet Explorer', 'Version', sVersion);
  except
  end;
  
  if (not RegLookupOK) or (RegLookupOK and (sVersion = '')) then begin
    if GetWindowsVersion = wvWin95 then
      Result := scHelpFileName + '.' + scHLP;
  end;
end;