{*******************************************************}
{                                                       }
{  Responsive Software     http://www.responsive.co.nz  }
{                                                       }
{  Copyright (c) 2003-2006 Responsive Software Limited  }
{                                                       }
{*******************************************************}

unit GeneralUtilities;

// this module contains low level utilities which do not depend on
// any of the application modules

interface

uses
  Grids, Graphics, Classes, Math, DBTables, StdCtrls, SyncObjs;

function ZeroDouble
  (Value : double) : double;

function IsDigit
  (C : char) : boolean;

function ExtractDigits
  (Str : string) : string;

function IsLetter
  (C : char) : boolean;

function IsAllDigits
  (Str : string) : boolean;

function IsIPAddress
  (Str : string) : boolean;

function TrimLeadingZeroes
  (Str : string) : string;

procedure OpenWebpage
  (URL : string);

function NowGMT: TDateTime;

procedure EraseFile
  (FileName : string);
  
function AddMonths
  (const date : TDateTime;
   const noOfMonths : word): TDateTime;

function TruncDollars
  (const Amount : int64) : int64;

function Encrypt
  (Str : string;
   Seed : integer) : string;

function DarkenColor
  (Color : TColor) : TColor;

function ConvertColorToHex
  (Color : TColor) : string;

function AppendBackslash
  (Str : string) : string;

function AddCommasToNumber
  (Str : string) : string;

procedure LogMsgInDevMode
  (Str : string);
  
function MemoryAllocated : integer;
function GetComputerName : string;
function GetUserName : string;
function GetProgramVersion : string;
function ExeDirectory : string;
procedure GetIPAddresses(StringList : TStringList);
function ChooseIPAddress : string;
function GetModeString : string;
procedure GetServerIPAddress;
function GetClientUserNameAndPassword : boolean;
function GetFirebirdUserNameAndPassword : boolean;

procedure WriteStrToStream
  (Str : string;
   Stream : TStream);
function ReadStrFromStream
  (Stream : TStream) : string;

function DateTimeStampStr : string;
function CurrentYearStr : string;
function CurrentYear : word;
function CurrentMonth : word;
function CurrentDay : word;

// these conversion routines are used when loading and saving
// data from and to the database
// and when converting text entered by the user
function ConvertStringToDouble
  (Str : string) : double;
function ConvertDoubleToString
  (Number : double) : string;
function ConvertStringToInt64
  (Str : string) : int64;
function ConvertInt64ToString
  (Number : int64) : string;
function ConvertCurrencyStringToInt64
  (Str : string) : int64;
function ConvertDisplayStringToDate
  (Str : string) : TDateTime;
function ConvertDateToDisplayString
  (Date : TDateTime) : string;
function ConvertDatabaseStringToDate
  (Str : string) : TDateTime;
function ConvertDateToDatabaseString
  (Date : TDateTime) : string;
function ConvertDatabaseStringToTime
  (Str : string) : TDateTime;
function ConvertTimeToDatabaseString
  (Time : TDateTime) : string;

// general formatting routines
function FormatDate
  (Date : TDateTime) : string;
function ShortFormatDate
  (Date : TDateTime) : string;
function FormatTime
  (DateTime : TDateTime) : string;
function FormatWeight
  (Weight : double) : string;
function FormatTemperature
  (Temperature : double) : string;
function FormatBoolean
  (Value : boolean) : string;
function FormatCount
  (Count : integer) : string;
function FormatCountWithParentheses
  (Count : integer) : string;
function FormatCurrency
  (Amount : Int64) : string;
function FormatCurrencyForDisplay
  (Amount : Int64) : string;
function FormatHours
  (Hours : double) : string;
function FormatPercentage
  (Percentage : double) : string;
function FormatFileAttribute
  (FileAttribute : integer) : string;
function FormatStringForCSV
  (Str : string) : string;

procedure SetUpStringGrid
  (StringGrid : TStringGrid;
   Headings : array of string;
   Widths : array of integer);

// split a string into elements in a string list
procedure SplitStrings
  (StringList : TStringList;
   Strings : string;
   Delimiter : char);

// combine the elements of a string list into a single string
procedure CombineStrings
  (StringList : TStringList;
   var Strings : string;
   Delimiter : char);

// format a string into separate lines of specified maximum length
// breaking on space if possible
procedure FormatText
  (Text : string;
   StringList : TStringList;
   MaxLineLength : integer);

// replace single quotes with two of the same
function RepeatSingleQuotes
  (Str : string) : string;

// replace double quotes with two of the same
function RepeatDoubleQuotes
  (Str : string) : string;

// replace all nulls (#0's) and spaces in a string
function ReplaceNullsEtc
  (Str : string) : string;

// restore nulls (#0's) and spaces in a string
function RestoreNullsEtc
  (Str : string) : string;

function RemoveChar
  (const Char : char;
   Str : string) : string;

function RepeatChar
  (const Char : char;
   const Length : integer) : string;

function ReplaceChar
  (const Char : char;
   const ReplacementChar : char;
   Str : string) : string;

function ReplaceSubstring
  (const Substr : string;
   const ReplacementSubstr : string;
   Str : string) : string;
   
// extract the first part of a string up to the first blank space
function ExtractFirstToken
  (Str : string) : string;

function ExtractInitials
  (Str : string) : string;

function ExtractAlphanumerics
  (Str : string) : string;

function ChooseColor
  (DefaultColor : TColor;
   var ChosenColor : TColor) : boolean;

function ChoosePicture
  (var FileName : string) : boolean;

function ChooseLZWFile
  (var FileName : string) : boolean;

function ChooseDirectory
  (var Directory : string;
   TitleStr : string;
   FilterStr : string) : boolean;

function ChooseFileOpen
  (var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;

function ChooseFileSave
  (var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;

function ChooseFile
  (var Directory : string;
   var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;

function CommaConcat
  (S : string;
   T : string) : string;

function BlankConcat
  (S : string;
   T : string) : string;

procedure DestroyList
  (var List : TList);

procedure ClearList
  (List : TList);

procedure SetComboBoxText
  (ComboBox : TComboBox;
   Text : string);

procedure GenerateRegistrationCode
  (CompanyName : string;
   ExpiryDate : TDateTime;
   NoOfWorkstations : integer;
   Unlimited : boolean;
   Accounts : boolean;
   POS : boolean;
   Documents : boolean;
   var RegistrationCode1 : string;
   var RegistrationCode2 : string;
   var RegistrationCode3 : string;
   var RegistrationCode4 : string);

function CheckRegistrationCode
  (CompanyName : string;
   ExpiryDate : TDateTime;
   NoOfWorkstations : integer;
   Unlimited : boolean;
   Accounts : boolean;
   POS : boolean;
   Documents : boolean;
   RegistrationCode1 : string;
   RegistrationCode2 : string;
   RegistrationCode3 : string;
   RegistrationCode4 : string) : boolean;

function FormatDBEngineError
  (E : EDBEngineError) : string;

procedure SaveRegistryString
  (Key : string;
   Value : string);

function GetRegistryString
  (Key : string) : string;

function OpenFileStream
  (FileName : string;
   ReadOnly : boolean) : TFileStream;

function GetFileContents
  (FileName : string) : string;

procedure SaveFileContents
  (FileName : string;
   FileContents : string;
   FileAge : integer=0);

type
  TMessageLog = class
  private
    FFileName : string;
    FMaxSize : integer;
    FFileLock : TCriticalSection;
    procedure Write
      (Str : string);
  public
    constructor Create
      (FileName : string;
       MaxSize : integer);
    destructor Destroy; override;
    procedure Log
      (Str : string);
  end;

type

  TDataItem = (diSaleDate,
               diSalesperson,
               diItem,
               diPaymentType);

  TSalesReportParameters = class
    OrderBy : TDataItem;

    SalespersonId : int64;
    ItemId : int64;
    PaymentTypeId : int64;

    TotalsOnly : boolean;
    BeginSaleDate : integer;     // offset from current date
    EndSaleDate : integer;       // offset from current date

    constructor Create;

    procedure SetText
      (Text : string);
    function Text : string;
    procedure Assign
      (ReportParameters : TSalesReportParameters);

    function NoSelectionCriteria : boolean;
  end;

  TReportData = class
    StringList : TStringList;
    constructor Create;
    destructor Destroy; override;
    procedure Write
      (Str : string);
    procedure WriteLine
      (Str : string);
    procedure WriteBoldLine
      (Str : string);
    procedure WriteItalicLine
      (Str : string);
    procedure WriteBoldItalicLine
      (Str : string);
    function LineCount : integer;
    function Line
      (i : integer) : string;
    function LineBold
      (i : integer) : boolean;
    function LineItalic
      (i : integer) : boolean;
    function LineBoldItalic
      (i : integer) : boolean;
  end;

implementation

uses
  ShellAPI,
  SysUtils, Types, Windows, Forms, Dialogs, Controls,
  ExtDlgs, Registry, WinSock, ChooseString,
  PromptUserNamePassword, Globals;

function ZeroDouble
  (Value : double) : double;
begin
  if Abs(Value) < 0.00000001 then
    Result := 0
  else
    Result := Value;
end;

function IsDigit
  (C : char) : boolean;
begin
  Result := C in ['0'..'9'];
end;

function ExtractDigits
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
    if IsDigit(Str[i]) then
      Result := Result + Str[i];
end;

function IsLetter
  (C : char) : boolean;
begin
  Result := (C in ['A'..'Z'])
    or (C in ['a'..'z']);
end;

function IsAllDigits
  (Str : string) : boolean;
var
  i : integer;
begin
  for i := 1 to Length(Str) do
    if not IsDigit(Str[i]) then
    begin
      Result := false;
      Exit;
    end;
  Result := true;
end;

function IsIPAddress
  (Str : string) : boolean;
var
  i : integer;
begin
  Result := false;
  if Str = '' then
    Exit;
  for i := 1 to Length(Str) do
    if not (IsDigit(Str[i]) or (Str[i] = '.')) then
      Exit;
  Result := true;
end;

function TrimLeadingZeroes
  (Str : string) : string;
begin
  while (Length(Str) > 0) and (Str[1] = '0') do
    Delete(Str,1,1);
  Result := Str;
end;

procedure OpenWebpage
  (URL : string);
var
  Str : string;
  pCh : PChar;
begin
  Str := 'http://' + URL;
  pCh := PChar(Str);
  ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL);
end;

function NowGMT: TDateTime;
var
  SystemTime : TSystemTime;
begin
  GetSystemTime(SystemTime);
  Result := SystemTimeToDateTime(SystemTime); 
end;

procedure EraseFile
  (FileName : string);
var
  f : textfile;
begin
  AssignFile(f,FileName);
  try
    Reset(f);
    CloseFile(f);
  except
    { if file cannot be opened then do nothing }
    Exit;
  end;
  Erase(f);
end;

function AddMonths
  (const date : TDateTime;
   const noOfMonths : word): TDateTime;
var
  year,month,day : word;
  maxDays : word;
begin
  DecodeDate( date, year, month, day);
  month := month + noOfMonths;
  year := year + month div 12;
  month := month mod 12;
  if month=0 then
  begin
    month := 12;
    year := year - 1;
  end;
  if month in [4,6,9,11] then
    maxDays := 30
  else if month = 2 then
  begin
    if (year mod 4) = 0 then
      maxDays := 29
    else
      maxDays := 28
  end
  else
    maxDays := 31;
  if day > maxDays then
    day := maxDays;
  Result := EncodeDate(year, month, day);
end;

function TruncDollars
  (const Amount : int64) : int64;
begin
  Result := Amount div 100 * 100;
end;

function Encrypt
  (Str : string;
   Seed : integer) : string;
var
  i : integer;
begin
  RandSeed := Seed;
  for i := 1 to Length(Str) do
    Str[i] := Char(Ord(Str[i]) xor Random(256));
  Result := Str;
end;

function DarkenColor
  (Color : TColor) : TColor;
begin
  Result := RGB( GetRValue(Color) * 8 div 10,
                 GetGValue(Color) * 8 div 10,
                 GetBValue(Color) * 8 div 10);
end;

function ConvertColorToHex
  (Color : TColor) : string;
begin
  Result := '#' + Format('%2x%2x%2x',[GetRValue(Color),GetGValue(Color),GetBValue(Color)]);
end;

function AppendBackslash
  (Str : string) : string;
begin
  // add a backslash to the end of the string if
  // one is not there already
  if (Length(Str) = 0) or (Str[Length(Str)] <> '\') then
    Result := Str + '\'
  else
    Result := Str;
end;

function AddCommasToNumber
  (Str : string) : string;
var
  DecimalPos : integer;
  InsertPos : integer;
begin
  // find decimal point
  DecimalPos := Pos('.',Str);
  // if no decimal point then
  // start at end of string
  if DecimalPos = 0 then
    InsertPos := Length(Str) - 2
  else
    InsertPos := DecimalPos - 3;
  Result := Str;
  while InsertPos > 1 do
  begin
    Insert(',',Result,InsertPos);
    Dec(InsertPos,3);
  end;
end;

procedure LogMsgInDevMode
  (Str : string);
begin
  if DevelopmentMode then
    MessageLog.Log(Str);
end;

procedure WriteStrToStream
  (Str : string;
   Stream : TStream);
var
  StrLength : integer;
begin
  StrLength := Length(Str);
  Stream.Write(StrLength,SizeOf(StrLength));
  Stream.Write(PChar(Str)^,StrLength);
end;

function ReadStrFromStream
  (Stream : TStream) : string;
var
  StrLength : integer;
  BytesRead : integer;
begin
  BytesRead := Stream.Read(StrLength,SizeOf(StrLength));
  if BytesRead = SizeOf(StrLength) then
  begin
    SetLength(Result,StrLength);
    BytesRead := Stream.Read(PChar(Result)^,StrLength);
    if BytesRead <> StrLength then
      Result := '';
  end else
    Result := '';
end;

function DateTimeStampStr : string;
begin
  Result := FormatDateTime('ddmmyy-hhmmss',Now);
end;

function CurrentYearStr : string;
begin
  Result := FormatDateTime('yyyy',Date);
end;

function CurrentYear : word;
var
  Day,
  Month,
  Year : word;
begin
  DecodeDate(Date,Year,Month,Day);
  Result := Year;
end;

function CurrentMonth : word;
var
  Day,
  Month,
  Year : word;
begin
  DecodeDate(Date,Year,Month,Day);
  Result := Month;
end;

function CurrentDay : word;
var
  Day,
  Month,
  Year : word;
begin
  DecodeDate(Date,Year,Month,Day);
  Result := Day;
end;

procedure SetUpStringGrid
  (StringGrid : TStringGrid;
   Headings : array of string;
   Widths : array of integer);
var
  i : integer;
  TotalWidths : integer;
  TotalColWidths : integer;
  AdjustedClientWidth : integer;
begin
  TotalWidths := 0;
  for i := Low(Widths) to High(Widths) do
    Inc(TotalWidths,Widths[i]);
  AdjustedClientWidth := TotalWidths * StringGrid.ClientWidth * 97 div 10000;
  // if no of headings and widths are not the same then raise an exception
  if High(Headings) <> High(Widths) then
    raise Exception.Create('Number of headings does not equal number of widths in SetUpStringGrid');
  StringGrid.FixedCols := 0;
  StringGrid.ColCount := High(Headings) - Low(Headings) + 1;
  for i := Low(Headings) to High(Headings) do
    StringGrid.Cells[i,0] := Headings[i];
  for i := Low(Widths) to High(Widths) - 1 do
    StringGrid.ColWidths[i] := AdjustedClientWidth * Widths[i] div TotalWidths;
  TotalColWidths := 0;
  for i := Low(Widths) to High(Widths) - 1 do
    Inc(TotalColWidths,StringGrid.ColWidths[i]);
  StringGrid.ColWidths[High(Widths)] := AdjustedClientWidth - TotalColWidths;
end;

procedure SplitStrings
  (StringList : TStringList;
   Strings : string;
   Delimiter : char);
var
  DelimiterPosition : integer;
  Str : string;
begin
  DelimiterPosition := Pos(Delimiter,Strings);
  while DelimiterPosition <> 0 do
  begin
    Str := Copy(Strings,0,DelimiterPosition-1);
    Delete(Strings,1,DelimiterPosition);
    StringList.Add(Str);
    DelimiterPosition := Pos(Delimiter,Strings);
  end;
  if Strings <> '' then
    StringList.Add(Strings);
end;

procedure CombineStrings
  (StringList : TStringList;
   var Strings : string;
   Delimiter : char);
var
  i : integer;
begin
  Strings := '';
  if StringList.Count = 0 then
    Exit;
  for i := 0 to StringList.Count - 2 do
    Strings := Strings + StringList[i] + Delimiter;
  Strings := Strings + StringList[StringList.Count - 1];
end;

procedure FormatText
  (Text : string;
   StringList : TStringList;
   MaxLineLength : integer);
var
  WorkStringList : TStringList;
  i : integer;
  WorkStr : string;
  LineLength : integer;
begin
  WorkStringList := TStringList.Create;
  try
    WorkStringList.Text := Text;
    for i := 0 to WorkStringList.Count - 1 do
    begin
      WorkStr := WorkStringList[i];
      if WorkStr = '' then
        StringList.Add('')
      else
        while WorkStr <> '' do
        begin
          // work back from end and look for space
          // split there if found otherwise take maximum
          LineLength := Length(WorkStr);
          if LineLength > MaxLineLength then
          begin
            LineLength := MaxLineLength;
            while (LineLength > 0) and (WorkStr[LineLength] <> ' ') do
              Dec(LineLength);
            if LineLength = 0 then
              LineLength := MaxLineLength;
          end;
          Text := Copy(WorkStr,1,LineLength);
          System.Delete(WorkStr,1,LineLength);
          StringList.Add(Text);
        end;
    end;
  finally
    WorkStringList.Free;
  end;
end;

function RepeatSingleQuotes
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
  begin
    if Str[i] = '''' then
      Result := Result + ''''''
    else
      Result := Result + Str[i];
  end;
end;

function RepeatDoubleQuotes
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
  begin
    if Str[i] = '"' then
      Result := Result + '""'
    else
      Result := Result + Str[i];
  end;
end;

function ReplaceNullsEtc
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
  begin
    if Str[i] = #0 then
      Result := Result + NullReplacement
    else if Str[i] = ' ' then
      Result := Result + SpaceReplacement
    else if Str[i] = Chr(13) then
      Result := Result + CRReplacement
    else if Str[i] = Chr(10) then
      Result := Result + LFReplacement
    else
      Result := Result + Str[i];
  end;
end;

function RestoreNullsEtc
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  i := 1;
  while i <= Length(Str) do
  begin
    if Copy(Str,i,Length(NullReplacement)) = NullReplacement then
    begin
      Result := Result + #0;
      Inc(i,Length(NullReplacement));
    end else if Copy(Str,i,Length(SpaceReplacement)) = SpaceReplacement then
    begin
      Result := Result + ' ';
      Inc(i,Length(SpaceReplacement));
    end else if Copy(Str,i,Length(CRReplacement)) = CRReplacement then
    begin
      Result := Result + Chr(13);
      Inc(i,Length(CRReplacement));
    end else if Copy(Str,i,Length(LFReplacement)) = LFReplacement then
    begin
      Result := Result + Chr(10);
      Inc(i,Length(LFReplacement));
    end else
    begin
      Result := Result + Str[i];
      Inc(i);
    end;
  end;
end;

function RemoveChar
  (const Char : char;
   Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
    if Str[i] <> Char then
      Result := Result + Str[i];
end;

function RepeatChar
  (const Char : char;
   const Length : integer) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length do
    Result := Result + Char;
end;

function ReplaceChar
  (const Char : char;
   const ReplacementChar : char;
   Str : string) : string;
var
  i : integer;
begin
  Result := Str;
  for i := 1 to Length(Str) do
    if Str[i] = Char then
      Result[i] := ReplacementChar;
end;

function ReplaceSubstring
  (const Substr : string;
   const ReplacementSubstr : string;
   Str : string) : string;
var
  i : integer;
begin
  Result := '';
  i := 1;
  while i <= Length(Str) do
  begin
    if Copy(Str,i,Length(Substr)) = Substr then
    begin
      Result := Result + ReplacementSubstr;
      Inc(i,Length(Substr));
    end else
    begin
      Result := Result + Str[i];
      Inc(i);
    end;
  end;
end;

function ExtractFirstToken
  (Str : string) : string;
var
  SpacePosition : integer;
begin
  SpacePosition := Pos(' ',Str);
  if SpacePosition > 0 then
    Result := Copy(Str,0,SpacePosition-1)
  else
    Result := Str;
end;

function ExtractInitials
  (Str : string) : string;
var
  i : integer;
  InitialFound : boolean;
begin
  Result := '';
  InitialFound := false;
  for i := 1 to Length(Str) do
    if (Str[i] <> ' ') and (not InitialFound) then
    begin
      Result := Result + Str[i] + ' ';
      InitialFound := true;
    end else if Str[i] = ' ' then
      InitialFound := false;
  Result := TrimRight(Result);
end;

function ExtractAlphanumerics
  (Str : string) : string;
var
  i : integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
    if IsLetter(Str[i]) or IsDigit(Str[i]) then
      Result := Result + Str[i];
end;

function MemoryAllocated : integer;
var
  HeapStatus : THeapStatus;
begin
  {$WARNINGS OFF}
  HeapStatus := GetHeapStatus;
  {$WARNINGS ON}
  Result := HeapStatus.TotalAllocated;
end;

function GetComputerName : string;
var
  Length : DWORD;
begin
  Length := MAX_COMPUTERNAME_LENGTH + 1;
  SetLength(Result, Length);
  if not Windows.GetComputerName(PChar(Result), Length) then
    RaiseLastOSError;
  SetLength(Result, Length)
end;

function GetUserName : string;
var
  Length : DWORD;
begin
  Length := MAX_COMPUTERNAME_LENGTH + 1;
  SetLength(Result, Length);
  if not Windows.GetUserName(PChar(Result), Length) then
//    RaiseLastOSError;
  begin
    Result := 'NO USER';
    Exit;
  end;
  SetLength(Result, Length - 1)
end;

procedure GetBuildInfo(var V1, V2, V3, V4: Word);
var
   VerInfoSize,
   VerValueSize,
   Dummy : DWORD;
   VerInfo : Pointer;
   VerValue : PVSFixedFileInfo;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  With VerValue^ do
  begin
    V1 := dwFileVersionMS shr 16;
    V2 := dwFileVersionMS and $FFFF;
    V3 := dwFileVersionLS shr 16;
    V4 := dwFileVersionLS and $FFFF;
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

function GetProgramVersion: String;
var
  V1, V2, V3, V4: Word;
begin
  GetBuildInfo(V1, V2, V3, V4);
  Result := IntToStr(V1) + '.' +
    IntToStr(V2) + '.' +
    IntToStr(V3) + '.' +
    IntToStr(V4);
end;

function ExeDirectory : string;
begin
  Result := ExtractFilePath(Application.ExeName);
end;

procedure GetIPAddresses
  (StringList : TStringList);
type
  TaPInAddr = array[0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  Phe : PHostEnt;
  PPtr : PaPInAddr;
  Buffer : array[0..63] of char;
  I : Integer;
  GInitData : TWSADATA;
begin
  try
    WSAStartUp($101, GInitData);
    GetHostName(Buffer, SizeOf(Buffer));
    Phe := GetHostByName(Buffer);
    if Phe <> nil then
    begin
      PPtr := PaPInAddr(Phe^.h_addr_list);
      I := 0;
      while PPtr^[I] <> nil do begin
        StringList.Add(StrPas(inet_ntoa(pptr^[I]^)));
        Inc(I);
      end;
    end;
  finally
    WSACleanUp;
  end;
end;

function ChooseIPAddress : string;
begin
  if IPAddresses.Count = 0 then
    Result := ''
  else if IPAddresses.Count = 1 then
    Result := IPAddresses[0]
  else begin
    if ChooseStringForm.Choose(
      'Network IP address',
      'Please identify network IP address',
      IPAddresses) then
      Result := ChooseStringForm.StringChoice
    else
      Result := '';
  end;
end;

function GetModeString : string;
begin
  if POSMode then
    Result := 'POS'
  else if ClientMode then
    Result := 'Client'
  else if ServerMode then
    Result := 'Server'
  else
    Result := '';
end;

procedure GetServerIPAddress;
begin
  // try to get server IP address from registry
  ServerIPAddress := GetRegistryString('ServerIPAddress');
  // always prompt every time in case the user wants to change it
  ServerIPAddress := InputBox('Server Address','Please enter server address',ServerIPAddress);
  // save it back to registry
  SaveRegistryString('ServerIPAddress',ServerIPAddress);
  // try to get server port from registry
  ServerPortNumber := StrToIntDef(GetRegistryString('ServerPortNumber'),DefaultPortNumber);
  // always prompt
  ServerPortNumber := StrToIntDef(InputBox('Server Port Number','Please enter server port number',
    IntToStr(ServerPortNumber)),DefaultPortNumber);
  // save it back to registry
  SaveRegistryString('ServerPortNumber',IntToStr(ServerPortNumber));
end;

function GetClientUserNameAndPassword : boolean;
begin
  Result := false;
  // get last user name used from registry
  PromptUserNamePasswordForm.UserName := GetRegistryString('ClientUserName');
  // prompt for user name and password
  if PromptUserNamePasswordForm.Prompt then
  begin
    // convert user name to upper case
    ClientUserName := UpperCase(PromptUserNamePasswordForm.UserName);
    // convert password to lower case
    ClientPassword := LowerCase(PromptUserNamePasswordForm.Password);
    // save user name back to registry
    SaveRegistryString('ClientUserName',ClientUserName);
    // return true
    Result := true;
  end;
end;

function GetFirebirdUserNameAndPassword : boolean;
begin
  Result := false;
  // get last user name used from registry
  PromptUserNamePasswordForm.UserName := GetRegistryString('FirebirdUserName');
  // prompt for user name and password
  if PromptUserNamePasswordForm.Prompt then
  begin
    FirebirdUserName := PromptUserNamePasswordForm.UserName;
    FirebirdPassword := PromptUserNamePasswordForm.Password;
    // save user name back to registry
    SaveRegistryString('FirebirdUserName',FirebirdUserName);
    // return true
    Result := true;
  end;
end;

function ConvertStringToDouble
  (Str : string) : double;
begin
  try
    Result := StrToFloat(Str);
  except
    Result := 0;
  end;
end;

function ConvertDoubleToString
  (Number : double) : string;
begin
  Result := FloatToStr(Number);
end;

function ConvertStringToInt64
  (Str : string) : int64;
begin
  try
    Result := StrToInt64(Str);
  except
    Result := 0;
  end;
end;

function ConvertCurrencyStringToInt64
  (Str : string) : int64;
var
  DecimalPos : integer;
  IntegerStr : string;
  FractionStr : string;
  Negative : boolean;
begin
  try
    Str := Trim(Str);
    if Pos('-',Str) = 1 then
    begin
      Delete(Str,1,1);
      Negative := true;
    end else
      Negative := false;
    DecimalPos := Pos('.',Str);
    if DecimalPos = 0 then
    begin
      // don't allow more than 15 digits
      if Length(Str) > 15 then
        Result := 0
      else
        Result := StrToInt64(Str) * 100
    end else begin
      IntegerStr := Copy(Str,1,DecimalPos-1);
      // don't allow more than 15 digits before the decimal point
      if Length(IntegerStr) > 15 then
        Result := 0
      else begin
        FractionStr := Copy(Str,DecimalPos+1,Length(Str));
        if Length(FractionStr) = 0 then
          FractionStr := '00'
        else if Length(FractionStr) = 1 then
          FractionStr := FractionStr + '0';
        if Length(IntegerStr) = 0 then
          IntegerStr := '0';
        Result := StrToInt64(IntegerStr) * 100 + StrToInt64(Copy(FractionStr,1,2))
      end;
    end;
    if Negative then
      Result := -Result;
  except
    Result := 0;
  end;
end;

function ConvertInt64ToString
  (Number : int64) : string;
begin
  Result := IntToStr(Number);
end;

function ConvertDisplayStringToDate
  (Str : string) : TDateTime;
var
  Day : word;
  Month : word;
  Year : word;
begin
  try
    Day := StrToInt(Copy(Str,1,2));
    Month := StrToInt(Copy(Str,4,2));
    Year := StrToInt(Copy(Str,7,4));
    Result := EncodeDate(Year,Month,Day);
  except
    Result := 0;
  end;
end;

function ConvertDateToDisplayString
  (Date : TDateTime) : string;
begin
  Result := DateTimeToStr(Date);
end;

function ConvertDatabaseStringToDate
  (Str : string) : TDateTime;
var
  Day : word;
  Month : word;
  Year : word;
begin
  try
    Day := StrToInt(Copy(Str,9,2));
    Month := StrToInt(Copy(Str,6,2));
    Year := StrToInt(Copy(Str,1,4));
    Result := EncodeDate(Year,Month,Day);
  except
    Result := 0;
  end;
end;

function ConvertDateToDatabaseString
  (Date : TDateTime) : string;
begin
  Result := FormatDateTime('yyyy-mm-dd',Date);
end;

function ConvertDatabaseStringToTime
  (Str : string) : TDateTime;
var
  Sec : word;
  Min : word;
  Hour : word;
begin
  try
    Sec := StrToInt(Copy(Str,7,2));
    Min := StrToInt(Copy(Str,4,2));
    Hour := StrToInt(Copy(Str,1,2));
    Result := EncodeTime(Hour,Min,Sec,0);
  except
    Result := 0;
  end;
end;

function ConvertTimeToDatabaseString
  (Time : TDateTime) : string;
begin
  Result := FormatDateTime('hh:nn:ss',Time);
end;

function FormatDate
  (Date : TDateTime) : string;
begin
  if Date = 0 then
    Result := ''
  else
    Result := DateTimeToStr(Date);
end;

function ShortFormatDate
  (Date : TDateTime) : string;
begin
  if Date = 0 then
    Result := ''
  else begin
    if (Length(ShortDateFormat) > 0) and (UpperCase(ShortDateFormat[1]) = 'M') then
      Result := FormatDateTime( 'mm/dd/yy',Date)
    else
      Result := FormatDateTime( 'dd/mm/yy',Date);
  end;
end;

function FormatTime
  (DateTime : TDateTime) : string;
begin
  if Date = 0 then
    Result := ''
  else
    Result := FormatDateTime( 'hh:mm:ss', DateTime);
end;

function FormatWeight
  (Weight : double) : string;
begin
  if Weight = 0 then
    Result := ''
  else
    Result := FloatToStrF(Weight,ffFixed,10,2);
end;

function FormatTemperature
  (Temperature : double) : string;
begin
  if Temperature = 0 then
    Result := ''
  else
    Result := FloatToStrF(Temperature,ffFixed,10,2);
end;

function FormatBoolean
  (Value : boolean) : string;
begin
  if Value then
    Result := 'Y'
  else
    Result := 'N';
end;

function FormatCount
  (Count : integer) : string;
begin
  if Count = 0 then
    Result := ''
  else
    Result := IntToStr(Count);
end;

function FormatCountWithParentheses
  (Count : integer) : string;
begin
  if Count = 0 then
    Result := ''
  else
    Result := '(' + IntToStr(Count) + ')';
end;

// assumes that the Amount value is positive
function BaseFormatCurrency
  (Amount : Int64) : string;
var
  IntegerStr : string;
  FractionStr : string;
begin
  IntegerStr := IntToStr(Amount div 100);
  FractionStr := IntToStr(Amount mod 100);
  if Length(FractionStr) = 0 then
    FractionStr := '00'
  else if Length(FractionStr) = 1 then
    FractionStr := '0' + FractionStr;
  Result := IntegerStr + '.' + FractionStr;
end;

function FormatCurrency
  (Amount : Int64) : string;
var
  Negative : boolean;
begin
  // remove negative sign and add back after formatting
  Negative := (Amount < 0);
  Amount := Abs(Amount);
  if Amount = 0 then
    Result := ''
  else
    Result := BaseFormatCurrency(Amount);
  if Negative then
    Result := '-' + Result;
end;

function FormatCurrencyForDisplay
  (Amount : Int64) : string;
var
  Negative : boolean;
begin
  // remove negative sign and add back after formatting
  Negative := (Amount < 0);
  Amount := Abs(Amount);
  Result := AddCommasToNumber(BaseFormatCurrency(Amount));
  if Negative then
    Result := '(' + Result + ')'
  else
    Result := Result + ' ';
end;

function FormatHours
  (Hours : double) : string;
begin
  if Hours = 0 then
    Result := ''
  else
    Result := FloatToStrF(Hours,ffFixed,10,2);
end;

function FormatPercentage
  (Percentage : double) : string;
begin
  if Percentage = 0 then
    Result := ''
  else
    Result := FloatToStrF(Percentage,ffFixed,10,2) + '%';
end;

function FormatFileAttribute
  (FileAttribute : integer) : string;
begin
{$WARNINGS OFF}
  Result := '';
  if (faReadOnly and FileAttribute) <> 0 then
    Result := Result + 'r'
  else
    Result := Result + '-';
  if (faArchive and FileAttribute) <> 0 then
    Result := Result + 'a'
  else
    Result := Result + '-';
  if (faSysFile and FileAttribute) <> 0 then
    Result := Result + 's'
  else
    Result := Result + '-';
  if (faHidden and FileAttribute) <> 0 then
    Result := Result + 'h'
  else
    Result := Result + '-';
{$WARNINGS ON}
end;

function FormatStringForCSV
  (Str : string) : string;
begin
  Result := '"' + Str + '"';
end;

function ChooseColor
  (DefaultColor : TColor;
   var ChosenColor : TColor) : boolean;
var
  ColorDialog : TColorDialog;
begin
  Result := false;
  ColorDialog := TColorDialog.Create(nil);
  with ColorDialog do
    ColorDialog.Color := DefaultColor;
  if ColorDialog.Execute then
  begin
    ChosenColor := ColorDialog.Color;
    Result := true;
  end;
  ColorDialog.Free;
end;

function ChoosePicture
  (var FileName : string) : boolean;
var
  OpenPictureDialog : TOpenPictureDialog;
  FilePath : string;
begin
  FilePath := ExtractFilePath(FileName);
  Result := false;
  OpenPictureDialog := TOpenPictureDialog.Create(nil);
  with OpenPictureDialog do
  begin
    Filter := 'Bitmaps (*.BMP)|*.BMP'
      + '|JPegs (*.JPG)|*.JPG'
      + '|Any file (*.*)|*.*';
    FilterIndex := 1;
    FileName := '';
    if FilePath <> '' then
      InitialDir := FilePath
    else
      InitialDir := ExeDirectory;
    Title := 'Select Picture';
  end;
  if OpenPictureDialog.Execute then
  begin
    FileName := OpenPictureDialog.FileName;
    Result := true;
  end;
  OpenPictureDialog.Free;
end;

function ChooseLZWFile
  (var FileName : string) : boolean;
var
  OpenDialog : TOpenDialog;
begin
  Result := false;
  OpenDialog := TOpenDialog.Create(nil);
  with OpenDialog do
  begin
    Filter :=
        'LZW files (*.LZW)|*.LZW'
      + '|Any file (*.*)|*.*';
    FilterIndex := 1;
    FileName := '';
    InitialDir := ExeDirectory;
    Title := 'Select File';
  end;
  if OpenDialog.Execute then
  begin
    FileName := OpenDialog.FileName;
    Result := true;
  end;
  OpenDialog.Free;
end;

function ChooseDirectory
  (var Directory : string;
   TitleStr : string;
   FilterStr : string) : boolean;
var
  OpenDialog : TOpenDialog;
begin
  Result := false;
  OpenDialog := TOpenDialog.Create(nil);
  with OpenDialog do
  begin
    Filter := FilterStr;
    FilterIndex := 1;
    FileName := '';
    InitialDir := Directory;
    Title := TitleStr;
  end;
  if OpenDialog.Execute then
  begin
    Directory := ExtractFilePath(OpenDialog.FileName);
    Result := true;
  end;
  OpenDialog.Free;
end;

function ChooseFileOpen
  (var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;
var
  OpenDialog : TOpenDialog;
begin
  Result := false;
  OpenDialog := TOpenDialog.Create(nil);
  OpenDialog.Filter := FilterStr;
  OpenDialog.FilterIndex := 1;
  OpenDialog.FileName := '';
  OpenDialog.InitialDir := ExtractFilePath(FileName);
  OpenDialog.Title := TitleStr;
  if OpenDialog.Execute then
  begin
    FileName := OpenDialog.FileName;
    Result := true;
  end;
  OpenDialog.Free;
end;

function ChooseFileSave
  (var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;
var
  SaveDialog : TSaveDialog;
begin
  Result := false;
  SaveDialog := TSaveDialog.Create(nil);
  SaveDialog.Filter := FilterStr;
  SaveDialog.FilterIndex := 1;
  SaveDialog.InitialDir := ExtractFilePath(FileName);
  SaveDialog.FileName := ExtractFileName(FileName);
  SaveDialog.Title := TitleStr;
  if SaveDialog.Execute then
  begin
    FileName := SaveDialog.FileName;
    Result := true;
  end;
  SaveDialog.Free;
end;

function ChooseFile
  (var Directory : string;
   var FileName : string;
   TitleStr : string;
   FilterStr : string) : boolean;
var
  OpenDialog : TOpenDialog;
begin
  Result := false;
  OpenDialog := TOpenDialog.Create(nil);
  with OpenDialog do
  begin
    Filter := FilterStr;
    FilterIndex := 1;
    FileName := '';
    InitialDir := Directory;
    Title := TitleStr;
  end;
  if OpenDialog.Execute then
  begin
    FileName := OpenDialog.FileName;
    Result := true;
  end;
  OpenDialog.Free;
end;

function CommaConcat
  (S : string;
   T : string) : string;
// concatenate two strings adding a comma only if both
// strings are non-null
begin
  if (S<>'') and (T<>'') then
    S := S + ', ';
  Result := S + T;
end;

function BlankConcat
  (S : string;
   T : string) : string;
// concatenate two strings adding a blank only if both
// strings are non-null
begin
  if (S<>'') and (T<>'') then
    S := S + ' ';
  Result := S + T;
end;

procedure DestroyList
  (var List : TList);
var
  i : integer;
begin
  if List <> nil then
  begin
    for i := 0 to List.Count - 1 do
      TObject(List[i]).Free;
    List.Free;
    List := nil;
  end;
end;

procedure ClearList
  (List : TList);
var
  i : integer;
begin
  if List <> nil then
  begin
    for i := 0 to List.Count - 1 do
      TObject(List[i]).Free;
    List.Clear;
  end;
end;

// this should be used whenever setting Text in a
// drop down style combo box to ensure that ItemIndex
// remains consistent
// simply updating the Text property does not cause
// the ItemIndex property to be updated
procedure SetComboBoxText
  (ComboBox : TComboBox;
   Text : string);
begin
  ComboBox.ItemIndex := ComboBox.Items.IndexOf(Text);
  ComboBox.Text := Text;
end;

procedure GenerateRegistrationCode
  (CompanyName : string;
   ExpiryDate : TDateTime;
   NoOfWorkstations : integer;
   Unlimited : boolean;
   Accounts : boolean;
   POS : boolean;
   Documents : boolean;
   var RegistrationCode1 : string;
   var RegistrationCode2 : string;
   var RegistrationCode3 : string;
   var RegistrationCode4 : string);
var
  i : integer;
  Seed : integer;
  Features : integer;
begin
  Features := 0;
  if Accounts then
    Features := Features + $01;
  if POS then
    Features := Features + $02;
  if Documents then
    Features := Features + $04;
  if Unlimited then
    Features := Features + $08;
  Seed := RegistrationCodeRandSeed;
  for i := 1 to Length(CompanyName) do
    Seed := Seed + Ord(CompanyName[i]);
  for i := 1 to Length(DevelopmentCompanyName) do
    Seed := Seed + Ord(DevelopmentCompanyName[i]);
  // ignore expiry date and no of workstations if Unlimited option selected
  if not Unlimited then
  begin
    Seed := Seed + Trunc(ExpiryDate);
    Seed := Seed + NoOfWorkstations * 123;
  end;
  Seed := Seed + Features * 12;
  RandSeed := Seed;

  RegistrationCode1 := '';
  RegistrationCode1 := RegistrationCode1 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode1 := RegistrationCode1 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode1 := RegistrationCode1 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode1 := RegistrationCode1 + Char(RandomRange(Ord('A'),Ord('Z')));

  RegistrationCode2 := '';
  RegistrationCode2 := RegistrationCode2 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode2 := RegistrationCode2 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode2 := RegistrationCode2 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode2 := RegistrationCode2 + Char(RandomRange(Ord('0'),Ord('9')));

  RegistrationCode3 := '';
  RegistrationCode3 := RegistrationCode3 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode3 := RegistrationCode3 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode3 := RegistrationCode3 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode3 := RegistrationCode3 + Char(RandomRange(Ord('A'),Ord('Z')));

  RegistrationCode4 := '';
  RegistrationCode4 := RegistrationCode4 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode4 := RegistrationCode4 + Char(RandomRange(Ord('A'),Ord('Z')));
  RegistrationCode4 := RegistrationCode4 + Char(RandomRange(Ord('0'),Ord('9')));
  RegistrationCode4 := RegistrationCode4 + Char(RandomRange(Ord('0'),Ord('9')));
end;

function CheckRegistrationCode
  (CompanyName : string;
   ExpiryDate : TDateTime;
   NoOfWorkstations : integer;
   Unlimited : boolean;
   Accounts : boolean;
   POS : boolean;
   Documents : boolean;
   RegistrationCode1 : string;
   RegistrationCode2 : string;
   RegistrationCode3 : string;
   RegistrationCode4 : string) : boolean;
var
  CorrectRegistrationCode1 : string;
  CorrectRegistrationCode2 : string;
  CorrectRegistrationCode3 : string;
  CorrectRegistrationCode4 : string;
begin
  GenerateRegistrationCode
    (CompanyName,
     ExpiryDate,
     NoOfWorkstations,
     Unlimited,
     Accounts,
     POS,
     Documents,
     CorrectRegistrationCode1,
     CorrectRegistrationCode2,
     CorrectRegistrationCode3,
     CorrectRegistrationCode4);
  Result :=     (RegistrationCode1 = CorrectRegistrationCode1)
            and (RegistrationCode2 = CorrectRegistrationCode2)
            and (RegistrationCode3 = CorrectRegistrationCode3)
            and (RegistrationCode4 = CorrectRegistrationCode4);
end;

function FormatDBEngineError
  (E : EDBEngineError) : string;
var
  Str : string;
  i : integer;
begin
  Str := '';
  for i := 0 to E.ErrorCount - 1 do
  begin
    Str := Str + 'BDE Category - ' + IntToStr(E.Errors[i].Category) + Chr(VK_RETURN);
    Str := Str + 'BDE Sub Code - ' + IntToStr(E.Errors[i].SubCode) + Chr(VK_RETURN);
    Str := Str + E.Errors[i].Message + Chr(VK_RETURN);
  end;
  Result := Str;
end;

procedure SaveRegistryString
  (Key : string;
   Value : string);
begin
  with TRegistry.Create do
  begin
    OpenKey(RegistryKey,true);
    WriteString(Key,Value);
    CloseKey;
    Free;
  end;
end;

function GetRegistryString
  (Key : string) : string;
begin
  with TRegistry.Create do
  begin
    OpenKey(RegistryKey,true);
    Result := ReadString(Key);
    CloseKey;
    Free;
  end;
end;

function OpenFileStream
  (FileName : string;
   ReadOnly : boolean) : TFileStream;
var
  opened : boolean;
  exists : boolean;
  Retries : integer;
begin
  Result := nil;
  opened := false;
  exists := FileExists(FileName);
  Retries := 0;
  while not opened do
  begin
    try
      if ReadOnly then
      begin
        if exists then
          Result := TFileStream.Create(FileName,fmShareDenyNone or fmOpenRead)
        else
          Exit;
      end else begin
        if exists then
          Result := TFileStream.Create(FileName,fmShareExclusive or fmOpenReadWrite)
        else
          Result := TFileStream.Create(FileName,fmShareExclusive or fmCreate);
      end;
      opened := true;
    except
      on E:Exception do
      begin
        // keep trying until file is opened
        // but count retries and show error message when limit is reached
        Inc(Retries);
        if ServerMode then
        begin
          if Retries > NoOfDatabaseRetries * 2 then
          begin
            MessageLog.Log(E.Message);
            raise;
          end;
        end else begin
          if Retries > NoOfDatabaseRetries then
          begin
            ShowMessage(E.Message);
            if MessageDlg('Do you wish to retry the operation that caused the error?',
              mtConfirmation, [mbYes, mbNo], 0) = mrNo then
              raise
            else
              Retries := 0;
          end;
        end;
        Sleep(PauseBetweenRetries);
      end;
    end;
  end;
  Result.Seek(0,soFromBeginning);
end;

function GetFileContents
  (FileName : string) : string;
const
  MaxBytesRead = 1024;
var
  FileStream : TFileStream;
  Buffer : string;
  BytesRead : integer;
begin
  Result := '';
  // try to open file
  FileStream := nil;
  try
    FileStream := OpenFileStream(FileName,true);
  except
    FileStream.Free;
    FileStream := nil;
  end;
  try
    if FileStream <> nil then
    begin
      SetLength(Buffer,MaxBytesRead);
      FillChar(Buffer[1],MaxBytesRead,0);
      repeat
        try
          BytesRead := FileStream.Read(Buffer[1],MaxBytesRead);
        except
          BytesRead := 0;
        end;
        if BytesRead > 0 then
        begin
          SetLength(Buffer,BytesRead);
          Result := Result + Buffer;
        end;
      until BytesRead = 0;
    end;
  finally
    FileStream.Free;
  end;
end;

procedure SaveFileContents
  (FileName : string;
   FileContents : string;
   FileAge : integer);
var
  FileStream : TFileStream;
begin
  // delete existing file
  SysUtils.DeleteFile(FileName);
  // open file
  FileStream := OpenFileStream(FileName,false);
  try
    FileStream.Write(PChar(FileContents)^,Length(FileContents));
    // set date/time stamp if specified
    if FileAge <> 0 then
      FileSetDate(FileStream.Handle,FileAge);
  finally
    FileStream.Free;
  end;
end;

{***** TMessageLog methods ****************************************************}

constructor TMessageLog.Create
  (FileName : string;
   MaxSize : integer);
begin
  FFileName := FileName;
  FMaxSize := MaxSize;
  FFileLock := TCriticalSection.Create;
end;

destructor TMessageLog.Destroy;
begin
  FFileLock.Free;
end;

// write a string to the log file
procedure TMessageLog.Write;
var
  F : file;
  CurrentPos : integer;
  CurrentPosStr : string;
  Buffer : array[1..500 + 2] of byte;
  P : PChar;
  Retry : boolean;
  SaveMode : byte;
  nRetries : integer;

  procedure WriteStr
    (Str : string);
  // move string to buffer and perform block write to file
  var
    StrLength : integer;
  begin
    StrCopy(P,PChar(Str));
    StrLength := Length(Str);
    Buffer[StrLength + 1] := $0D;
    Buffer[StrLength + 2] := $0A;
    BlockWrite(F,Buffer,StrLength + 2);
  end;

begin
  // truncate string if it is too long
  if Length(Str) > 500 then
    Delete(Str,500 + 1,Length(Str));
  // P allows us to access buffer as a string
  P := @Buffer;
  // assign and open file
  AssignFile(F,FFileName);

  Retry := false;
  CurrentPos := 0;
  nRetries:=0;
  repeat
    try
      Retry := false;
      SaveMode := FileMode;
      FileMode := fmShareExclusive or fmOpenReadWrite;
      Reset(F,1);
      FileMode := SaveMode;
      try
        // read the first 9 bytes (7 characters plus $0D/$0A)
        BlockRead(F,Buffer,9);
        Buffer[8] := 0;
        CurrentPos := StrToInt(P);
      except
        // if error occurs while reading current position then reset to zero
        CurrentPos := 0;
      end
    except
      on E:EInOutError do
      begin
        // if file does not exist then create
        if E.ErrorCode = 2 then
        begin
          SaveMode := FileMode;
          FileMode := fmShareExclusive or fmOpenReadWrite;
          Rewrite(F,1);
          FileMode := SaveMode;
          CurrentPos := 0;
        end else begin
          Sleep(PauseBetweenRetries);
          Inc(nRetries);
          if nRetries > NoOfDatabaseRetries then
            exit;
          // otherwise just keep trying up to 10 times
          Retry := true;
        end;
      end;
    end;
  until not Retry;

  // position file where string is to be written
  Seek(F,9 + CurrentPos);
  // write string to file
  WriteStr(Str);
  // record current position
  CurrentPos := FilePos(F) - 9;
  // write ending message
  WriteStr('********** MESSAGE LOG **********');
  // if current position has exceeded max size then reset
  if CurrentPos > FMaxSize then
    CurrentPos := 0;
  // convert to string
  CurrentPosStr := IntToStr(CurrentPos);
  // pad with leading zeroes
  while Length(CurrentPosStr) < 7 do
    CurrentPosStr := '0' + CurrentPosStr;
  // write current position at start of file
  Seek(F,0);
  WriteStr(CurrentPosStr);
  // close file
  CloseFile(F);
end;

// write a string to the log file after prepending date and time
procedure TMessageLog.Log
  (Str : string);
var
  CurrentDateTime : TDateTime;
  Hour,Min,Sec,MSec : word;
  MSecStr : string;
  TimeStampStr : string;
begin
  CurrentDateTime := Now;
  DecodeTime(CurrentDateTime,Hour,Min,Sec,MSec);
  MSecStr := IntToStr(MSec);
  while Length(MSecStr) < 3 do
    MSecStr := '0' + MSecStr;
  TimeStampStr := ComputerName + FormatDateTime(' yymmdd hhnnss ',CurrentDateTime) + MSecStr;
  FFileLock.Acquire;
  try
    Write( TimeStampStr + ' ' + Str);
  finally
    FFileLock.Release;
  end;
end;

{***** TSalesReportParameters methods *****************************************}

constructor TSalesReportParameters.Create;
begin
  inherited;
  OrderBy := diSaleDate;
end;

procedure TSalesReportParameters.SetText
  (Text : string);
var
  StringList : TStringList;
begin
  OrderBy := diSaleDate;
  SalespersonId := 0;
  ItemId := 0;
  PaymentTypeId := 0;
  TotalsOnly := false;
  BeginSaleDate := 0;
  EndSaleDate := 0;
  StringList := TStringList.Create;
  try
    StringList.Text := Text;
    try
      OrderBy := TDataItem(StrToIntDef(StringList[0],integer(diSaleDate)));
      SalespersonId := StrToInt64Def(StringList[1],0);
      ItemId := StrToInt64Def(StringList[2],0);
      PaymentTypeId := StrToInt64Def(StringList[3],0);
      TotalsOnly := StrToBool(StringList[4]);
      BeginSaleDate := StrToIntDef(StringList[5],0);
      EndSaleDate := StrToIntDef(StringList[6],0);
    except
      // if an error occurs then don't worry as we may have an empty string
    end;
  finally
    StringList.Free;
  end;
end;

function TSalesReportParameters.Text : string;
var
  StringList : TStringList;
begin
  StringList := TStringList.Create;
  try
    StringList.Add(IntToStr(integer(OrderBy)));
    StringList.Add(IntToStr(SalespersonId));
    StringList.Add(IntToStr(ItemId));
    StringList.Add(IntToStr(PaymentTypeId));
    StringList.Add(BoolToStr(TotalsOnly));
    StringList.Add(IntToStr(BeginSaleDate));
    StringList.Add(IntToStr(EndSaleDate));
    Result := StringList.Text;
  finally
    StringList.Free;
  end;
end;

procedure TSalesReportParameters.Assign
  (ReportParameters : TSalesReportParameters);
begin
  SetText(ReportParameters.Text);
end;

function TSalesReportParameters.NoSelectionCriteria : boolean;
begin
  Result := false;
end;

{***** TReportData methods ****************************************************}

const
  idBold = 1;
  idItalic = 2;
  idBoldItalic = 3;

constructor TReportData.Create;
begin
  StringList := TStringList.Create;
end;

destructor TReportData.Destroy;
begin
  StringList.Free;
end;

procedure TReportData.Write
  (Str : string);
begin
  if StringList.Count = 0 then
    StringList.Add('');
  StringList.Strings[StringList.Count - 1] :=
    StringList.Strings[StringList.Count - 1] + Str;
end;

procedure TReportData.WriteLine
  (Str : string);
begin
  Write(Str);
  StringList.Add('');
end;

procedure TReportData.WriteBoldLine
  (Str : string);
begin
  Write(Str);
  StringList.Objects[StringList.Count - 1] := pointer(idBold);
  StringList.Add('');
end;

procedure TReportData.WriteItalicLine
  (Str : string);
begin
  Write(Str);
  StringList.Objects[StringList.Count - 1] := pointer(idItalic);
  StringList.Add('');
end;

procedure TReportData.WriteBoldItalicLine
  (Str : string);
begin
  Write(Str);
  StringList.Objects[StringList.Count - 1] := pointer(idBoldItalic);
  StringList.Add('');
end;

function TReportData.LineCount : integer;
begin
  Result := StringList.Count;
end;

function TReportData.Line
  (i : integer) : string;
begin
  Result := StringList[i];
end;

function TReportData.LineBold
  (i : integer) : boolean;
begin
  Result := integer(StringList.Objects[i]) = idBold;
end;

function TReportData.LineItalic
  (i : integer) : boolean;
begin
  Result := integer(StringList.Objects[i]) = idItalic;
end;

function TReportData.LineBoldItalic
  (i : integer) : boolean;
begin
  Result := integer(StringList.Objects[i]) = idBoldItalic;
end;

end.