instfunc.pas

源代码

  end;

  ResultCode := STILL_ACTIVE;
  { A process handle won't always be returned, e.g. if DDE was used } 
  if Info.hProcess <> 0 then begin
    if WaitUntilIdle then
      WaitForInputIdle(Info.hProcess, INFINITE);
    if WaitUntilTerminated then
      { Wait until the process returns, but still process any messages that
        arrive. }
      repeat
        { Process any pending messages first because MsgWaitForMultipleObjects
          (called below) only returns when *new* messages arrive }
        if Assigned(ProcessMessagesProc) then
          ProcessMessagesProc;
      until MsgWaitForMultipleObjects(1, Info.hProcess, False, INFINITE, QS_ALLINPUT) <> WAIT_OBJECT_0+1;
    { Get the exit code. Will be set to STILL_ACTIVE if not yet available }
    GetExitCodeProcess(Info.hProcess, DWORD(ResultCode));
    CloseHandle(Info.hProcess);
  end;
end;

function CheckForMutexes(Mutexes: String): Boolean;
{ Returns True if any of the mutexes in the comma-separated Mutexes string
  exist }
var
  I: Integer;
  M: String;
  H: THandle;
begin
  Result := False;
  repeat
    I := Pos(',', Mutexes);
    if I = 0 then I := Maxint;
    M := Trim(Copy(Mutexes, 1, I-1));
    if M <> '' then begin
      H := OpenMutex(SYNCHRONIZE, False, PChar(M));
      if H <> 0 then begin
        CloseHandle(H);
        Result := True;
        Break;
      end;
    end;
    Delete(Mutexes, 1, I);
  until Mutexes = '';
end;

function ModifyPifFile(const Filename: String; const CloseOnExit: Boolean): Boolean;
{ Changes the "Close on exit" setting of a .pif file. Returns True if it was
  able to make the change. }
var
  F: TFile;
  B: Byte;
begin
  { Note: Specs on the .pif format were taken from
    http://smsoft.chat.ru/en/pifdoc.htm }
  Result := False;
  F := TFile.Create(Filename, fdOpenExisting, faReadWrite, fsNone);
  try
    { Is it a valid .pif file? }
    if F.Size.Lo >= $171 then begin
      F.Seek($63);
      F.ReadBuffer(B, SizeOf(B));
      { Toggle the "Close on exit" bit }
      if (B and $10 <> 0) <> CloseOnExit then begin
        B := B xor $10;
        F.Seek($63);
        F.WriteBuffer(B, SizeOf(B));
      end;
      Result := True;
    end;
  finally
    F.Free;
  end;
end;

function GetComputerNameString: String;
var
  Buf: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
  Size: DWORD;
begin
  Size := SizeOf(Buf);
  if GetComputerName(Buf, Size) then
    Result := Buf
  else
    Result := '';
end;

function GetUserNameString: String;
var
  Buf: array[0..255] of Char;
  BufSize: DWORD;
begin
  BufSize := SizeOf(Buf);
  if GetUserName(Buf, BufSize) then
    Result := Buf
  else
    Result := '';
end;

{ Work around problem in D2's declaration of the function }
function NewAdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
  const NewState: TTokenPrivileges; BufferLength: DWORD;
  PreviousState: PTokenPrivileges; ReturnLength: PDWORD): BOOL; stdcall;
  external advapi32 name 'AdjustTokenPrivileges';

procedure RestartComputer;
{ Restarts the computer. The function will NOT return if it is successful,
  since Windows kills the process immediately after sending it a WM_ENDSESSION
  message. }

  procedure RestartErrorMessage;
  begin
    MessageBox(0, PChar(SetupMessages[msgErrorRestartingComputer]),
      PChar(SetupMessages[msgErrorTitle]), MB_OK or MB_ICONEXCLAMATION);
  end;

var
  Token: THandle;
  TokenPriv: TTokenPrivileges;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';  { don't localize }
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then begin
    if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
       {$IFNDEF Delphi3orHigher} @Token {$ELSE} Token {$ENDIF}) then begin
      RestartErrorMessage;
      Exit;
    end;

    LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, TokenPriv.Privileges[0].Luid);

    TokenPriv.PrivilegeCount := 1;
    TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

    NewAdjustTokenPrivileges(Token, False, TokenPriv, 0, nil, nil);

    { Cannot test the return value of AdjustTokenPrivileges. }
    if GetLastError <> ERROR_SUCCESS then begin
      RestartErrorMessage;
      Exit;
    end;
  end;
  if not ExitWindowsEx(EWX_REBOOT, 0) then
    RestartErrorMessage;

  { If ExitWindows/ExitWindowsEx were successful, program execution halts here
    (at least on Win95) }
end;

procedure DelayDeleteFile(const Filename: String; const Tries: Integer);
{ Attempts to delete Filename, retrying up to Tries times if the file is in use.
  It delays 250 msec between tries. }
var
  I: Integer;
begin
  for I := 0 to Tries-1 do begin
    if I <> 0 then Sleep(250);
    if Windows.DeleteFile(PChar(Filename)) or
       (GetLastError = ERROR_FILE_NOT_FOUND) or
       (GetLastError = ERROR_PATH_NOT_FOUND) then
      Break;
  end;
end;

function MakePendingFileRenameOperationsChecksum: TMD5Digest;
{ Calculates a checksum of the current PendingFileRenameOperations registry
  value (on NT 4+ platforms) or of the current WININIT.INI file (on non-NT
  platforms). The caller can use this checksum to determine if
  PendingFileRenameOperations or WININIT.INI was changed (perhaps by another
  program). }
var
  Context: TMD5Context;
  K: HKEY;
  S: String;
  WinInitFile: String;
  F: TFile;
  Buf: array[0..4095] of Byte;
  BytesRead: Cardinal;
begin
  MD5Init(Context);
  try
    if UsingWinNT then begin
      if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'SYSTEM\CurrentControlSet\Control\Session Manager',
         0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin
        if RegQueryMultiStringValue(K, 'PendingFileRenameOperations', S) then
          MD5Update(Context, S[1], Length(S));
        { When "PendingFileRenameOperations" is full, it spills over into
          "PendingFileRenameOperations2" }
        if RegQueryMultiStringValue(K, 'PendingFileRenameOperations2', S) then
          MD5Update(Context, S[1], Length(S));
        RegCloseKey(K);
      end;
    end
    else begin
      WinInitFile := AddBackslash(GetWinDir) + 'WININIT.INI';
      if NewFileExists(WinInitFile) then begin
        F := TFile.Create(WinInitFile, fdOpenExisting, faRead, fsRead);
        try
          while True do begin
            BytesRead := F.Read(Buf, SizeOf(Buf));
            if BytesRead = 0 then
              Break;
            MD5Update(Context, Buf, BytesRead);
          end;
        finally
          F.Free;
        end;
      end;
    end;
  except
    { don't propogate exceptions }
  end;
  Result := MD5Final(Context);
end;

procedure EnumFileReplaceOperationsFilenames(const EnumFunc: TEnumFROFilenamesProc;
  Param: Pointer);
{ Enumerates all the filenames in the current PendingFileRenameOperations
  registry value or WININIT.INI file. The function does not distinguish between
  source and destination filenames; it enumerates both. }

  procedure DoNT;

    procedure DoValue(const K: HKEY; const ValueName: PChar);
    var
      S: String;
      P, PEnd: PChar;
    begin
      if not RegQueryMultiStringValue(K, ValueName, S) then
        Exit;
      P := PChar(S);
      PEnd := P + Length(S);
      while P < PEnd do begin
        if P[0] = '!' then
          { Note: '!' means that MoveFileEx was called with the
            MOVEFILE_REPLACE_EXISTING flag }
          Inc(P);
        if StrLComp(P, '\??\', 4) = 0 then
          Inc(P, 4);
        if P[0] <> #0 then
          EnumFunc(P, Param);
        Inc(P, StrLen(P) + 1);
      end;
    end;

  var
    K: HKEY;
  begin
    if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'SYSTEM\CurrentControlSet\Control\Session Manager',
       0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin
      try
        DoValue(K, 'PendingFileRenameOperations');
        { When "PendingFileRenameOperations" is full, it spills over into
          "PendingFileRenameOperations2" }
        DoValue(K, 'PendingFileRenameOperations2');
      finally
        RegCloseKey(K);
      end;
    end;
  end;

  procedure DoNonNT;
  var
    WinInitFile: String;
    F: TTextFileReader;
    Line, Filename: String;
    InRenameSection: Boolean;
    P: Integer;
  begin
    WinInitFile := AddBackslash(GetWinDir) + 'WININIT.INI';
    if not NewFileExists(WinInitFile) then
      Exit;
    try
      F := TTextFileReader.Create(WinInitFile, fdOpenExisting, faRead, fsRead);
      try
        InRenameSection := False;
        while not F.Eof do begin
          Line := Trim(F.ReadLine);
          if (Line = '') or (Line[1] = ';') then
            Continue;
          if Line[1] = '[' then begin
            InRenameSection := (CompareText(Line, '[rename]') = 0);
          end
          else if InRenameSection then begin
            P := Pos('=', Line);
            if P > 0 then begin
              Filename := Copy(Line, 1, P-1);
              if (Filename <> '') and (CompareText(Filename, 'NUL') <> 0) then
                EnumFunc(Filename, Param);
              Filename := Copy(Line, P+1, Maxint);
              if (Filename <> '') and (CompareText(Filename, 'NUL') <> 0) then
                EnumFunc(Filename, Param);
            end;
          end;
        end;
      finally
        F.Free;
      end;
    except
      { ignore exceptions }
    end;
  end;

begin
  if UsingWinNT then
    DoNT
  else
    DoNonNT;
end;

procedure RegisterServer(const Filename: String; const FailCriticalErrors: Boolean);
var
  SaveCurrentDir: String;
  SaveCursor: HCURSOR;
  NewErrorMode, SaveErrorMode: UINT;
  LibHandle: THandle;
  RegisterServerProc: function: HRESULT; stdcall;
  RegisterCode: HRESULT;
begin
  SaveCurrentDir := GetCurrentDir;
  SaveCursor := SetCursor(LoadCursor(0, IDC_WAIT));  { show the 'hourglass' cursor }
  if FailCriticalErrors then
    NewErrorMode := SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS
  else
    NewErrorMode := SEM_NOOPENFILEERRORBOX;
  SaveErrorMode := SetErrorMode(NewErrorMode);
  try
    SetCurrentDir(PathExtractDir(Filename));
    LibHandle := SafeLoadLibrary(Filename, NewErrorMode);
    if LibHandle = 0 then
      Win32ErrorMsg('LoadLibrary');
    try
      @RegisterServerProc := GetProcAddress(LibHandle, 'DllRegisterServer');
      if @RegisterServerProc = nil then
        raise Exception.Create(SetupMessages[msgErrorRegisterServerMissingExport]);
      RegisterCode := RegisterServerProc;
      if FAILED(RegisterCode) then
        raise Exception.Create(FmtSetupMessage(msgErrorFunctionFailed,