unit TMSIWSystem;

interface

uses
  SysUtils, SyncObjs, Windows, Classes;

{$I TMSIWCompilerDefines.inc}

type
  TFileInfo = (fiCompanyName, fiFileDescription, fiFileVersion, fiIntName, fiLegalCopyright
    , fiLegalTradmark, fiOrigFilename, fiProductName, fiProductVersion, fiComments);

// Procs
  procedure Check(const ACondition: Boolean; const AMsg: string);
  function CompareDateTime(adDate1, adDate2: TDateTime): Integer;
  function CompareInteger(anInt1, anInt2: Integer): Integer;
  procedure LogFileAppend(const AData: string; const AExtension: string = 'log');
  procedure FileAppend(const APathName: string; const AData: string);
  function FileContents(const asPathname: string): string;
  // FileMake instead of FileCreate to avoid conflict with one in SysUtils and possible
  // use of wrong one as they can share the same signatures
  procedure FileMake(const APathName: string; const AData: string = '';
   const AOverwrite: Boolean = True);
  procedure FileCopy(const ASource, ADest: string; const AOverwrite: Boolean = False);
  procedure FileDelete(const asPathname: string);
  procedure FileMove(const ASource, ADest: string; const AOverwrite: Boolean = False);
  function GetCurrentPath: string;
  function IncludeTrailingPathDelim(const asPath: string): string;
  function FindInstanceContainingResource(const AResName: string; AType: PChar): LongWord;
  function GetPropertyList(pClassInfo: Pointer): TStringList;
  function iif(const AValue: string; const ATrue: string; const AFalse: string = ''): string;
    overload;
  function iif(const AValue: Boolean; const ATrue: string; const AFalse: string = ''): string;
    overload;
  function iif(const AValue: Boolean; const ATrue, AFalse: Integer): Integer; overload;
  function InDelphiIDE: boolean;
  function MakeTempFile(APath: string = ''; APrefix: string = 'ATZ'): string;
  function Minutes(const iMin: Integer): TDateTime;
  procedure NotImp;
  function PosInIntArray(const iLook: Integer; Search: array of Integer): Integer;
  function PosInStrArray(const sLook: string; Search: array of string): Integer;
  function RemoveFileExt(const AFilename: string): string;
  function GetFileInfo(asFileName: string; axItem: TFileInfo): string;
  function IsNumeric(const c1: Char): Boolean;
  procedure Shell(const asCmd, asFile: string; const abWait: Boolean = false);
  function TempPath: string;
  function Win32SafeCheck(ARetVal: BOOL): BOOL;
  function MakeDirectory(Dir: string; RaiseOnError: boolean = true): Boolean;
  function DirectoryExists(const Directory: string): Boolean;
  procedure SetThreadName(const AName: string);
  // cross compiler function to get locale settings avoiding warnings
  function IWFormatSettings: TFormatSettings;

const
  BoolStr: array[Boolean] of string = ('False', 'True');
  BoolChar: array[Boolean] of Char = ('F', 'T');
  YesNoStr: array[Boolean] of string = ('No', 'Yes');
  CR = #13;
  LF = #10;
  TAB = #9;
  EOL = CR + LF;
  QT = '''';
  PATHDELIM = '\';

var
  GCSLogFile: TCriticalSection;
  GVoid: string = '';
  GAppPathname: string = ''; // w:\source\guess\guess.exe
  GAppFilename: string = ''; // guess.exe
  gsAppPath: string = ''; // w:\source\guess\
  gsAppName: string = '';
  gsTempPath: string = '';
  GSystemPath: string = '';

implementation

uses
  //See note at interface uses
  TypInfo;

function FindInstanceContainingResource(const AResName: String; AType: PChar): LongWord;
var
  LCurModule: PLibModule;
begin
  // TODO: for pkgs, this loosk in itself first, need to look in main EXE
  Result := HInstance;
  if FindResource(Result, PChar(AResName), AType) = 0 then begin
    LCurModule := LibModuleList;
    while LCurModule <> nil do begin
      Result := LCurModule.Instance;
      if FindResource(Result, PChar(AResName), AType) <> 0 then begin
        Exit;
      end;
      LCurModule := LCurModule.Next;
    end;
    Result := 0;
  end;
end;

procedure Check(const ACondition: Boolean; const AMsg: string);
begin
  if not ACondition then begin
    raise Exception.Create(AMsg);
  end;
end;

function GetPropertyList;
var
  i, iPropCount: integer;
  PropList: PPropList;
begin
  Result := TStringList.Create; try
    iPropCount := GetTypeData(pClassInfo)^.PropCount;
    if iPropCount > 0 then begin
      GetMem(PropList, iPropCount * SizeOf(Pointer)); try
        // GetPropInfos could also be used - but will return unsorted, and cannot be filtered
        iPropCount := GetPropList(pClassInfo, tkProperties, PropList);
        for i := 0 to iPropCount - 1 do begin
          Result.AddObject(string(PropList^[i].Name), TObject(PropList^[i]));
        end;
      finally FreeMem(PropList); end;
    end;
  except
    FreeAndNil(Result);
    raise;
  end;
end;

procedure NotImp;
begin
  raise Exception.Create('Not implemented.');
end;

function IncludeTrailingPathDelim(const asPath: string): string;
begin
  Result := asPath;
  if Length(Result) > 0 then begin
    if Result[Length(Result)] <> PATHDELIM then begin
      result := Result + PATHDELIM;
    end;
  end;
end;

procedure LogFileAppend(const AData: string; const AExtension: string = 'log');
begin
  GCSLogFile.Enter;
  try
    FileAppend(gsAppPath + gsAppName + '.' + AExtension,
        DateTimeToStr(Now) + ' ' + AData + EOL);
  finally
    GCSLogfile.Leave;
  end;
end;

procedure FileAppend(const APathName: string; const AData: string);
var
  str: RawByteString;
  TotalBytes: Integer;
begin
  with TFileStream.Create(APathName, iif(FileExists(APathname), fmOpenWrite, fmCreate)) do try
    Position := Size;
    str := UTF8Encode(AData);
    TotalBytes := Length(str);
    WriteBuffer(str[1], TotalBytes);

  finally Free; end;
end;

procedure FileMake(const APathName: string; const AData: string = '';
  const AOverwrite: Boolean = True);
var
  str: RawByteString;
begin
  if FileExists(APathname) and (AOverwrite = False) then begin
    raise Exception.Create(APathname + ' already exists.');
  end;
  with TFileStream.Create(APathName, fmCreate) do try
    if Length(AData) > 0 then begin
      str := UTF8Encode(AData);
      WriteBuffer(str[1], Length(str));
    end;
  finally Free; end;
end;

function FileContents;
var
  LBuffer: RawByteString;
begin
  Result := '';
  if FileExists(asPathName) then begin
    with TFileStream.Create(asPathName, fmOpenRead + fmShareDenyWrite) do try
      if Size > 0 then begin
        // templates are ASCII
        SetLength(LBuffer, Size);
        ReadBuffer(LBuffer[1], Size);
        Result := UTF8ToUnicodeString(LBuffer);
      end;
    finally Free; end;
  end;
end;

function CompareInteger;
begin
  if anInt1 > anInt2 then begin
    result := 1;
  end else if anInt2 > anInt1 then begin
    result := -1;
  end else begin
    result := 0;
  end;
end;

function CompareDateTime;
begin
  if adDate1 > adDate2 then begin
    result := 1;
  end else if adDate2 > adDate1 then begin
    result := -1;
  end else begin
    result := 0;
  end;
end;

function Minutes(const iMin: Integer): TDateTime;
begin
  Result := EncodeTime(iMin div 60, iMin mod 60, 0, 0);
end;

function PosInIntArray;
var
  i1: integer;
begin
  result := -1;
  for i1 := low(Search) to high(Search) do begin
    if iLook = Search[i1] then begin
      result := i1;
      break;
    end;
  end;
end;

function PosInStrArray;
var
  i1: integer;
begin
  result := -1;
  for i1 := low(Search) to high(Search) do begin
    if sLook = Search[i1] then begin
      result := i1;
      break;
    end;
  end;
end;

function iif(const AValue: string; const ATrue: string; const AFalse: string = ''): string;
  overload;
begin
  if Length(AValue) > 0 then begin
    Result := ATrue;
  end else begin
    Result := AFalse;
  end;
end;

function iif(const AValue: Boolean; const ATrue: string; const AFalse: string = ''): string;
  overload;
begin
  if AValue then begin
    Result := ATrue;
  end else begin
    Result := AFalse;
  end;
end;

function iif(const AValue: Boolean; const ATrue, AFalse: Integer): Integer; overload;
begin
  if AValue then begin
    Result := ATrue;
  end else begin
    Result := AFalse;
  end;
end;

procedure FileDelete(const asPathname: string);
begin
  if not SysUtils.DeleteFile(asPathname) then begin
    raise exception.create(asPathname + ' could not be deleted.');
  end;
end;

function RemoveFileExt(const AFilename: string): string;
begin
  Result := ChangeFileExt(AFilename, '.nul');
  SetLength(Result, Length(Result) - 4);
end;

function InDelphiIDE: boolean;
begin
  Result := CompareText(ExtractFileName(ParamStr(0)), 'Delphi32.exe') = 0;
end;

{$DEFINE WIN32}

function TempPath: string;
var
  i: integer;
begin
  SetLength(Result, MAX_PATH);
  i := GetTempPath(Length(Result), PChar(Result));
  SetLength(Result, i);
  Result := IncludeTrailingPathDelim(Result);
end;

function MakeTempFile(APath: string = ''; APrefix: string = 'ATZ'): string;
begin
  if Length(APath) = 0 then begin
    APath := gsTempPath;
  end;
  SetLength(Result, MAX_PATH + 1);
  Win32SafeCheck(GetTempFileName(PChar(APath), PChar(APrefix), 0, PChar(Result)) <> 0);
  Result := PChar(Result);
end;

function IsNumeric(const c1: Char): Boolean;
begin
  Result := IsCharAlphaNumeric(c1) and not IsCharAlpha(c1);
end;

procedure Shell;
var
  PCmd: PChar;
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
begin
  // Fill with known state
  FillChar(StartInfo, SizeOf(TStartupInfo), #0);
  FillChar(ProcInfo, SizeOf(TProcessInformation), #0);
  StartInfo.cb := SizeOf(TStartupInfo);

  if length(asCmd) = 0 then begin
    PCmd := nil
  end else begin
    PCmd := PChar(asCmd);
  end;

  if CreateProcess(PCmd, PChar(asFile), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartInfo
    , ProcInfo) then begin
    if abWait then begin
      WaitForSingleObject(ProcInfo.hProcess, INFINITE)
    end;
  end else begin
    RaiseLastOSError;
  end;
end;

const
  cCompName = 'CompanyName';
  cFileDesc = 'FileDescription';
  cFileVer = 'FileVersion';
  cIntName = 'InternalName';
  cLegCopy = 'LegalCopyright';
  cLegTrad = 'LegalTrademarks';
  cOrgFile = 'OriginalFilename';
  cProdName = 'Productname';
  cProdVer = 'ProductVersion';
  cComments = 'Comments';

function GetFileInfo(asFileName: string; axItem: TFileInfo): string;
Type
  PLongInt = ^LongInt;
var
  Buffer: string;
  LangCharset: PLongInt;
  Value: pointer;
  Len: DWORD;
  sItem: string;
begin
  case axItem of
    fiCompanyName: sItem := 'CompanyName';
    fiFileDescription: sItem := 'FileDescription';
    fiFileVersion: sItem := 'FileVersion';
    fiIntName: sItem := 'InternalName';
    fiLegalCopyright: sItem := 'LegalCopyright';
    fiLegalTradmark: sItem := 'LegalTrademarks';
    fiOrigFilename: sItem := 'OriginalFilename';
    fiProductName: sItem := 'Productname';
    fiProductVersion: sItem := 'ProductVersion';
    fiComments: sItem := 'Comments';
  end;
  Result := '';
  Len := GetFileVersionInfoSize(PChar(asFileName), Len);
  if Len > 0 then begin
    SetLength(Buffer, Len);
    if GetFileVersionInfo(PChar(asFileName), 0, Len, PChar(Buffer)) then begin
      VerQueryValue(PChar(Buffer), '\VarFileInfo\Translation', pointer(LangCharset), Len);
      if VerQueryValue(PChar(Buffer), PChar('\StringFileInfo\' + IntToHex(LoWord(LangCharset^), 4)
        + IntToHex(HiWord(LangCharset^), 4) + '\' + sItem), Value, Len) then begin
        Result := PChar(Value);
      end;
    end;
  end;
end;

procedure Main;
var
  i: integer;
begin
  if IsLibrary then begin
    // This is done this way for DLLs. ParamStr(0) returns the host EXE
    SetLength(GAppPathname, MAX_PATH + 1); // Add 1 for the null character
    GetModuleFileName(HInstance, PChar(GAppPathname), Length(GAppPathname));
    GAppPathname := PChar(GAppPathname);
  end else begin
    // This is done as an if statement because GetModuleFilename does not work for services
    GAppPathname := ParamStr(0);
  end;
  if Copy(GAppPathName,1,4)='\\?\' then begin
    GAppPathName := Copy(GAppPathName, 5, length(GAppPathName)-4);
  end;
  if GAppPathName <> '' then begin
    GAppFilename := ExtractFileName(GAppPathname);
    gsAppPath := IncludeTrailingPathDelim(ExtractFilePath(GAppPathname));
    gsAppName := ExtractFilename(GAppPathname);
    if gsAppName<>'' then begin
      gsAppName := ChangeFileExt(gsAppName, '.nul');
      SetLength(gsAppName, Length(gsAppName) - 4);
    end;
  end;
  gsTempPath := TempPath;
  SetLength(GSystemPath, MAX_PATH);
  i := GetSystemDirectory(PChar(GSystemPath), Length(GSystemPath));
  Win32SafeCheck(i <> 0);
  SetLength(GSystemPath, i);
  GSystemPath := GSystemPath + PATHDELIM;
end;

procedure FileMove(const ASource, ADest: string; const AOverwrite: Boolean = False);
//TODO: Use OS APIs
begin
  FileCopy(ASource, ADest, AOverwrite);
  FileDelete(ASource);
end;

procedure FileCopy(const ASource, ADest: string; const AOverwrite: Boolean = False);
var
  xFileName: string;
  xPath: string;
begin
  xFileName := ExtractFileName(ADest);
  if FileExists(ADest) and not AOverwrite then begin
    raise Exception.Create('File copy failed. The file "' + xFileName + '" already exists in destination folder.');
  end else begin
    xPath := ExtractFilePath(ADest);
    if not ForceDirectories(xPath) then begin
      raise Exception.Create('File copy failed. The specified destination folder does not exist and could not be created.');
    end else
    if CopyFile(PChar(ASource), PChar(ADest), not AOverwrite) = False then begin
      raise Exception.Create('File copy Failed. The file "' + xFileName + '" could not be created: ' + SysErrorMessage(GetLastError));
    end;
  end;
end;

{$WARNINGS OFF}
function Win32SafeCheck(ARetVal: BOOL): BOOL;
begin
  Result := Win32Check(ARetVal);
end;
{$WARNINGS ON}

function GetCurrentPath: string;
begin
  SetLength(Result, MAX_PATH);
  GetCurrentDirectory(Length(Result), PChar(Result));
  Result := PChar(Result);
  Result := IncludeTrailingPathDelim(Result);
end;

procedure SetThreadName(const AName: string);
type
  TThreadNameInfo = record
    RecType: LongWord;  // Must be 0x1000
    Name: PAnsiChar;        // Pointer to name (in user address space)
    ThreadID: LongWord; // Thread ID (-1 indicates caller thread)
    Flags: LongWord;    // Reserved for future use. Must be zero
  end;
var
  xThreadNameInfo: TThreadNameInfo;
begin
  with xThreadNameInfo do begin
    RecType := $1000;
    Name := PAnsiChar(AnsiString(aName));
    ThreadID := $FFFFFFFF;
    Flags := 0;
  end;
  try
    // This is a wierdo Windows way to pass the info in
    RaiseException($406D1388, 0, SizeOf(xThreadNameInfo) div SizeOf(LongWord), {$IFNDEF VCL16ORABOVE}PDWord{$ELSE}PUINT_PTR{$ENDIF}(@xThreadNameInfo));
  except end;
end;

function IWFormatSettings: TFormatSettings;
begin
  {$IFDEF VCL15ORABOVE}
     {$WARN SYMBOL_PLATFORM OFF}
     Result := TFormatSettings.Create(GetThreadLocale);
     {$WARN SYMBOL_PLATFORM ON}
  {$ELSE}
      GetLocaleFormatSettings(GetThreadLocale, Result);
  {$ENDIF}
end;

function MakeDirectory(Dir: string; RaiseOnError: boolean = true): Boolean;
const
  LPathDelim = '\';
begin
  Result := true;
  try
    if Dir = '' then
    begin
      result:=false;
      abort;
    end;
    if Dir[Length(Dir)] = LPathDelim then
    begin
      Delete(Dir, Length(Dir), 1);
    end;
    if (Length(Dir) < 3) or (ExtractFilePath(Dir) = Dir) then exit; // avoid 'xyz:\' problem.
    if DirectoryExists(Dir) then Exit;
    Result := MakeDirectory(ExtractFilePath(Dir), true) and CreateDir(Dir);
  finally
    if RaiseOnError and (not result) then begin
      raise Exception.Create('MakeDirectory cannot create directory ' + Dir);
    end;
  end;
end;

function DirectoryExists(const Directory: string): Boolean;
begin
  Result := SysUtils.DirectoryExists(Directory);
end;

initialization
  Main;
  GCSLogFile := TCriticalSection.Create;

finalization
  FreeAndNil(GCSLogFile);

end.

