Componentes.Terceros.jcl/official/1.100/source/windows/JclMiscel.pas

515 lines
18 KiB
ObjectPascal

{**************************************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
{ License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
{ and limitations under the License. }
{ }
{ The Original Code is JclMiscel.pas. }
{ }
{ The Initial Developers of the Original Code are Members of Team JCL. Portions created by these }
{ individuals are Copyright (C) of these individuals. All Rights Reserved }
{ }
{ Contributors: }
{ Jeroen Speldekamp }
{ Peter Friese }
{ Marcel van Brakel }
{ Robert Marquardt (marquardt) }
{ John C Molyneux }
{ Matthias Thoma (mthoma) }
{ Petr Vones (pvones) }
{ }
{**************************************************************************************************}
{ }
{ Various miscellanuous routines that do not (yet) fit nicely into other units }
{ }
{**************************************************************************************************}
// Last modified: $Date: 2006-08-16 21:35:09 +0200 (mer., 16 août 2006) $
unit JclMiscel;
{$I jcl.inc}
interface
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
Windows,
JclBase;
// StrLstLoadSave
function SetDisplayResolution(const XRes, YRes: DWORD): Longint;
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile: string): Boolean;
function WinExec32(const Cmd: string; const CmdShow: Integer): Boolean;
function WinExec32AndWait(const Cmd: string; const CmdShow: Integer): Cardinal;
function WinExec32AndRedirectOutput(const Cmd: string; var Output: string; RawOutput: Boolean = False): Cardinal;
type
TJclKillLevel = (klNormal, klNoSignal, klTimeOut);
// klNormal: old shutdown style: waiting all applications to respond to the signals
// klNoSignal: do not send shutdown signal, all applications are killed (only Windows NT/2000/XP)
// klTimeOut: kill applications that do not respond within the timeout interval (only Windows 2000 and XP)
function ExitWindows(ExitCode: Cardinal): Boolean;
function LogOffOS(KillLevel: TJclKillLevel = klNormal): Boolean;
function PowerOffOS(KillLevel: TJclKillLevel = klNormal): Boolean;
function ShutDownOS(KillLevel: TJclKillLevel = klNormal): Boolean;
function RebootOS(KillLevel: TJclKillLevel = klNormal): Boolean;
function HibernateOS(Force, DisableWakeEvents: Boolean): Boolean;
function SuspendOS(Force, DisableWakeEvents: Boolean): Boolean;
function ShutDownDialog(const DialogMessage: string; TimeOut: DWORD;
Force, Reboot: Boolean): Boolean; overload;
function ShutDownDialog(const MachineName, DialogMessage: string; TimeOut: DWORD;
Force, Reboot: Boolean): Boolean; overload;
function AbortShutDown: Boolean; overload;
function AbortShutDown(const MachineName: string): Boolean; overload;
type
TJclAllowedPowerOperation = (apoHibernate, apoShutdown, apoSuspend);
TJclAllowedPowerOperations = set of TJclAllowedPowerOperation;
function GetAllowedPowerOperations: TJclAllowedPowerOperations;
// CreateProcAsUser
type
EJclCreateProcessError = class(EJclWin32Error);
procedure CreateProcAsUser(const UserDomain, UserName, PassWord, CommandLine: string);
procedure CreateProcAsUserEx(const UserDomain, UserName, Password, CommandLine: string;
const Environment: PChar);
{$IFDEF SUPPORTS_EXTSYM}
{$EXTERNALSYM ExitWindows}
{$ENDIF SUPPORTS_EXTSYM}
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL: https://jcl.svn.sourceforge.net:443/svnroot/jcl/tags/JCL-1.100-Build2646/jcl/source/windows/JclMiscel.pas $';
Revision: '$Revision: 1732 $';
Date: '$Date: 2006-08-16 21:35:09 +0200 (mer., 16 août 2006) $';
LogPath: 'JCL\source\windows'
);
{$ENDIF UNITVERSIONING}
implementation
uses
SysUtils,
JclResources, JclSecurity, JclStrings, JclSysUtils, JclWin32, JclSysInfo;
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile: string): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
SecAtrrs: TSecurityAttributes;
hInputFile, hOutputFile: THandle;
begin
Result := False;
hInputFile := CreateFile(PChar(InputFile), GENERIC_READ, FILE_SHARE_READ,
CreateInheritable(SecAtrrs), OPEN_EXISTING, FILE_ATTRIBUTE_TEMPORARY, 0);
if hInputFile <> INVALID_HANDLE_VALUE then
begin
hOutputFile := CreateFile(PChar(OutPutFile), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ, CreateInheritable(SecAtrrs), CREATE_ALWAYS,
FILE_ATTRIBUTE_TEMPORARY, 0);
if hOutputFile <> INVALID_HANDLE_VALUE then
begin
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hOutputFile;
StartupInfo.hStdInput := hInputFile;
Result := CreateProcess(nil, PChar(CommandLine), nil, nil, True,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo,
ProcessInfo);
if Result then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
CloseHandle(hOutputFile);
end;
CloseHandle(hInputFile);
end;
end;
function WinExec32(const Cmd: string; const CmdShow: Integer): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo, SizeOf(TStartupInfo), #0);
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := CmdShow;
Result := CreateProcess(nil, PChar(Cmd), nil, nil, False,
NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
if Result then
begin
WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
function WinExec32AndWait(const Cmd: string; const CmdShow: Integer): Cardinal;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
Result := Cardinal($FFFFFFFF);
FillChar(StartupInfo, SizeOf(TStartupInfo), #0);
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := CmdShow;
if CreateProcess(nil, PChar(Cmd), nil, nil, False, NORMAL_PRIORITY_CLASS,
nil, nil, StartupInfo, ProcessInfo) then
begin
WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
if WaitForSingleObject(ProcessInfo.hProcess, INFINITE) = WAIT_OBJECT_0 then
begin
if not GetExitCodeProcess(ProcessInfo.hProcess, Result) then
Result := Cardinal($FFFFFFFF);
end;
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
function WinExec32AndRedirectOutput(const Cmd: string; var Output: string; RawOutput: Boolean): Cardinal;
begin
Result := Execute(Cmd, Output, RawOutput);
end;
function KillLevelToFlags(KillLevel: TJclKillLevel): Cardinal;
begin
Result := 0;
case KillLevel of
klNoSignal:
if not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2, wvWin98,
wvWin98SE, wvWinME]) then
Result := EWX_FORCE;
klTimeOut:
if not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2, wvWin98,
wvWin98SE, wvWinME, wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4]) then
Result := EWX_FORCEIFHUNG;
end;
end;
function LogOffOS(KillLevel: TJclKillLevel): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := JclMiscel.ExitWindows(EWX_LOGOFF or KillLevelToFlags(KillLevel));
{$ENDIF MSWINDOWS}
{ TODO : implement at least LINUX variants throwing an exception }
end;
function PowerOffOS(KillLevel: TJclKillLevel): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := JclMiscel.ExitWindows(EWX_POWEROFF or KillLevelToFlags(KillLevel));
{$ENDIF MSWINDOWS}
end;
function ShutDownOS(KillLevel: TJclKillLevel): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := JclMiscel.ExitWindows(EWX_SHUTDOWN or KillLevelToFlags(KillLevel));
{$ENDIF MSWINDOWS}
end;
function RebootOS(KillLevel: TJclKillLevel): Boolean;
begin
{$IFDEF MSWINDOWS}
Result := JclMiscel.ExitWindows(EWX_REBOOT or KillLevelToFlags(KillLevel));
{$ENDIF MSWINDOWS}
end;
function ExitWindows(ExitCode: Cardinal): Boolean;
begin
{ TODO -cTest : Check for Win9x }
if (Win32Platform = VER_PLATFORM_WIN32_NT) and not EnableProcessPrivilege(True, SE_SHUTDOWN_NAME) then
Result := False
else
Result := ExitWindowsEx(ExitCode, SHTDN_REASON_MAJOR_APPLICATION or SHTDN_REASON_MINOR_OTHER);
end;
function HibernateOS(Force, DisableWakeEvents: Boolean): Boolean;
var
OldShutdownPrivilege: Boolean;
begin
{$IFDEF MSWINDOWS}
try
OldShutdownPrivilege := IsPrivilegeEnabled(SE_SHUTDOWN_NAME);
try
Result := EnableProcessPrivilege(True, SE_SHUTDOWN_NAME)
and SetSuspendState(True, Force, DisableWakeEvents);
finally
EnableProcessPrivilege(OldShutdownPrivilege, SE_SHUTDOWN_NAME);
end;
except
Result := False;
end;
{$ENDIF MSWINDOWS}
end;
function SuspendOS(Force, DisableWakeEvents: Boolean): Boolean;
var
OldShutdownPrivilege: Boolean;
begin
{$IFDEF MSWINDOWS}
try
OldShutdownPrivilege := IsPrivilegeEnabled(SE_SHUTDOWN_NAME);
try
Result := EnableProcessPrivilege(True, SE_SHUTDOWN_NAME)
and SetSuspendState(False, Force, DisableWakeEvents);
finally
EnableProcessPrivilege(OldShutdownPrivilege, SE_SHUTDOWN_NAME);
end;
except
Result := False;
end;
{$ENDIF MSWINDOWS}
end;
function ShutDownDialog(const DialogMessage: string; TimeOut: DWORD;
Force, Reboot: Boolean): Boolean;
begin
Result := ShutDownDialog('', DialogMessage, TimeOut, Force, Reboot);
end;
function ShutDownDialog(const MachineName, DialogMessage: string; TimeOut: DWORD;
Force, Reboot: Boolean): Boolean;
var
OldShutdownPrivilege: Boolean;
PrivilegeName: string;
begin
{$IFDEF MSWINDOWS}
if MachineName = '' then
PrivilegeName := SE_SHUTDOWN_NAME
else
PrivilegeName := SE_REMOTE_SHUTDOWN_NAME;
try
OldShutdownPrivilege := IsPrivilegeEnabled(PrivilegeName);
try
Result := EnableProcessPrivilege(True, PrivilegeName)
and InitiateSystemShutdown(PChar(MachineName), PChar(DialogMessage),
TimeOut, Force, Reboot);
finally
EnableProcessPrivilege(OldShutdownPrivilege, PrivilegeName);
end;
except
Result := False;
end;
{$ENDIF MSWINDOWS}
end;
function AbortShutDown: Boolean;
begin
Result := AbortShutDown('');
end;
function AbortShutDown(const MachineName: string): Boolean;
var
OldShutdownPrivilege: Boolean;
PrivilegeName: string;
begin
{$IFDEF MSWINDOWS}
if MachineName = '' then
PrivilegeName := SE_SHUTDOWN_NAME
else
PrivilegeName := SE_REMOTE_SHUTDOWN_NAME;
try
OldShutdownPrivilege := IsPrivilegeEnabled(PrivilegeName);
try
Result := EnableProcessPrivilege(True, PrivilegeName)
and AbortSystemShutDown(PChar(MachineName));
finally
EnableProcessPrivilege(OldShutdownPrivilege, PrivilegeName);
end;
except
Result := False;
end;
{$ENDIF MSWINDOWS}
end;
function SetDisplayResolution(const XRes, YRes: DWORD): Longint;
var
DevMode: TDeviceMode;
begin
Result := DISP_CHANGE_FAILED;
FillChar(DevMode, SizeOf(DevMode), #0);
DevMode.dmSize := SizeOf(DevMode);
if EnumDisplaySettings(nil, 0, DevMode) then
begin
DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
DevMode.dmPelsWidth := XRes;
DevMode.dmPelsHeight := YRes;
Result := ChangeDisplaySettings(DevMode, 0);
end;
end;
function GetAllowedPowerOperations: TJclAllowedPowerOperations;
begin
{$IFDEF MSWINDOWS}
Result := [];
try
if IsPwrSuspendAllowed then
Include(Result, apoSuspend);
if IsPwrHibernateAllowed then
Include(Result, apoHibernate);
if IsPwrShutdownAllowed then
Include(Result, apoShutdown);
except
Result := [];
end;
{$ENDIF MSWINDOWS}
end;
procedure CheckOSVersion;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
raise EJclError.CreateRes(@RsCreateProcNTRequiredError);
if Win32BuildNumber < 1057 then
raise EJclError.CreateRes(@RsCreateProcBuild1057Error);
end;
procedure CreateProcAsUser(const UserDomain, UserName, PassWord, CommandLine: string);
begin
CreateProcAsUserEx(UserDomain, UserName, Password, CommandLine, nil);
end;
{ TODO -cTest : Check for Win9x }
procedure CreateProcAsUserEx(const UserDomain, UserName, Password, CommandLine: string;
const Environment: PChar);
const
// default values for window stations and desktops
CreateProcDEFWINSTATION = 'WinSta0';
CreateProcDEFDESKTOP = 'Default';
CreateProcDOMUSERSEP = '\';
var
ConsoleTitle: string;
Help: string;
WinStaName: string;
DesktopName: string;
hUserToken: THandle;
hWindowStation: HWINSTA;
hDesktop: HDESK;
StartUpInfo: TStartUpInfo;
ProcInfo: TProcessInformation;
begin
// Step 1: check for the correct OS version
CheckOSVersion;
// Step 2: logon as the specified user
if not LogonUser(PChar(UserName), PChar(UserDomain), PChar(Password),
LOGON32_LOGON_INTERACTIVE, LOGON32_PROVIDER_DEFAULT, hUserToken) then
begin
case GetLastError of
ERROR_PRIVILEGE_NOT_HELD:
raise EJclCreateProcessError.CreateResFmt(@RsCreateProcPrivilegeMissing,
[GetPrivilegeDisplayName(SE_TCB_NAME), SE_TCB_NAME]);
ERROR_LOGON_FAILURE:
raise EJclCreateProcessError.CreateRes(@RsCreateProcLogonUserError);
ERROR_ACCESS_DENIED:
raise EJclCreateProcessError.CreateRes(@RsCreateProcAccessDenied);
else
raise EJclCreateProcessError.CreateRes(@RsCreateProcLogonFailed);
end;
end;
// Step 3: give the new user access to the current WindowStation and Desktop
hWindowStation:= GetProcessWindowStation;
WinStaName := GetUserObjectName(hWindowStation);
if WinStaName = '' then
WinStaName := CreateProcDEFWINSTATION;
if not SetUserObjectFullAccess(hWindowStation) then
begin
CloseHandle(hUserToken);
raise EJclCreateProcessError.CreateResFmt(@RsCreateProcSetStationSecurityError, [WinStaName]);
end;
hDesktop := GetThreadDesktop(GetCurrentThreadId);
DesktopName := GetUserObjectName(hDesktop);
if DesktopName = '' then
DesktopName := CreateProcDEFDESKTOP;
if not SetUserObjectFullAccess(hDesktop) then
begin
CloseHandle(hUserToken);
raise EJclCreateProcessError.CreateResFmt(@RsCreateProcSetDesktopSecurityError, [DesktopName]);
end;
// Step 4: set the startup info for the new process
ConsoleTitle := UserDomain + UserName;
FillChar(StartUpInfo, SizeOf(StartUpInfo), #0);
with StartUpInfo do
begin
cb:= SizeOf(StartUpInfo);
lpTitle:= PChar(ConsoleTitle);
Help := WinStaName + '\' + DeskTopName;
lpDesktop:= PChar(Help);
end;
// Step 5: create the child process
if not CreateProcessAsUser(hUserToken, nil, PChar(CommandLine), nil, nil,
False, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP, Environment, nil,
{$IFDEF FPC}
@StartUpInfo, @ProcInfo) then
{$ELSE}
StartUpInfo, ProcInfo) then
{$ENDIF FPC}
begin
case GetLastError of
ERROR_PRIVILEGE_NOT_HELD:
raise EJclCreateProcessError.CreateResFmt(@RsCreateProcPrivilegesMissing,
[GetPrivilegeDisplayName(SE_ASSIGNPRIMARYTOKEN_NAME), SE_ASSIGNPRIMARYTOKEN_NAME,
GetPrivilegeDisplayName(SE_INCREASE_QUOTA_NAME), SE_INCREASE_QUOTA_NAME]);
ERROR_FILE_NOT_FOUND:
raise EJclCreateProcessError.CreateResFmt(@RsCreateProcCommandNotFound, [CommandLine]);
else
raise EJclCreateProcessError.CreateRes(@RsCreateProcFailed);
end;
end;
// clean up
CloseWindowStation(hWindowStation);
CloseDesktop(hDesktop);
CloseHandle(hUserToken);
// if this code should be called although there has
// been an exception during invocation of CreateProcessAsUser,
// it will quite surely fail. you should make sure this doesn't happen.
// (it shouldn't happen due to the use of exceptions in the above lines)
CloseHandle(ProcInfo.hThread);
CloseHandle(ProcInfo.hProcess);
end;
{$IFDEF UNITVERSIONING}
initialization
RegisterUnitVersion(HInstance, UnitVersioning);
finalization
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
end.