With a few modifications I could now compile DavidB's start_VM console programm on Free Pascal (and it still works, allowing writes to disk from within Qemu):
// start_VM.pas
// based on start_VM.dpr by DavidB, * converted for FreePascal by Gerolf
program start_VM;
uses
Windows,
SysUtils,
// * Dialogs, Classes, Controls, TntSysUtils,
// * Math, (required on Delphi)
ShellApi;
type
_STORAGE_DEVICE_NUMBER = record
DeviceType: DWORD;
DeviceNumber: DWORD;
PartitionNumber: DWORD;
end;
STORAGE_DEVICE_NUMBER = _STORAGE_DEVICE_NUMBER;
TPWideCharArray = array[0..0] of PWideChar;
const
METHOD_BUFFERED = 0;
FILE_ANY_ACCESS = 0;
// * FILE_DEVICE_FILE_SYSTEM = $00000009;
FILE_DEVICE_MASS_STORAGE = $0000002D;
IOCTL_STORAGE_BASE = FILE_DEVICE_MASS_STORAGE;
IOCTL_STORAGE_GET_DEVICE_NUMBER =
((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or
($0420 shl 2) or METHOD_BUFFERED);
var
VolumesHandles: array of THandle;
LastError: integer;
procedure FlushToDisk(sDriveLetter: char);
var
hDrive: THandle;
begin
hDrive := 0;
try
hDrive := CreateFile(PAnsiChar('\\.\' + sDriveLetter + ':'),
GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0);
if FlushFileBuffers(hDrive) then // * FlushFileBuffers(hDrive);
writeln('Flushed drive ' + sDriveLetter + ':'); // *
finally
FileClose(hDrive); // * CloseHandle(hDrive);
end;
end;
function DismountVolume(ADrive: char): boolean;
const
FSCTL_DISMOUNT_VOLUME = (9 shl 16) or (0 shl 14) or (8 shl 2) or 0;
var
VolumeName: string;
BytesReturned: cardinal = 0;
begin
Result := False;
VolumeName := Format('\\.\%s:', [ADrive]);
SetLength(VolumesHandles, Length(VolumesHandles) + 1);
VolumesHandles[High(VolumesHandles)] :=
CreateFile(PChar(VolumeName), GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if VolumesHandles[High(VolumesHandles)] = INVALID_HANDLE_VALUE then
begin
LastError := GetLastError;
Exit;
end
else
writeln('Dismounted drive ' + ADrive + ':'); // *
Result := DeviceIoControl(VolumesHandles[High(VolumesHandles)],
FSCTL_DISMOUNT_VOLUME, nil, 0, nil, 0, BytesReturned, nil);
if not Result then
LastError := GetLastError;
end;
function StrLCopyW(Dest, Source: PWideChar; MaxLen: cardinal): PWideChar;
var
Count: cardinal;
begin
Result := Dest;
Count := 0;
while (Count < MaxLen) and (Source^ <> #0) do
begin
Dest^ := Source^;
Inc(Source);
Inc(Dest);
Inc(Count);
end;
Dest^ := #0;
end;
function StrPCopyW(Dest: PWideChar; const Source: WideString): PWideChar;
begin
Result := StrLCopyW(Dest, PWideChar(Source), Length(Source));
end;
var
zAppName: array[0..512] of widechar;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
Res: DWORD = 0;
i, udn, WaitTime: integer;
VolLet: array of char;
hVolume: THandle;
dwBytesReturned: DWORD;
sdn: STORAGE_DEVICE_NUMBER;
ComLine, QFolder: WideString;
NumArgs: PLongint = nil; // * NumArgs: integer = 0;
TempArgs: PPWideChar;
ParamStrW: array of WideString;
ParamCountW: integer;
StartInfo: TStartupInfo;
PQFolder: PWideChar;
ErrorMode: word;
begin
SetLength(ParamStrW, 0);
ParamCountW := -1;
TempArgs := nil;
try
TempArgs := CommandLineToArgvW(GetCommandLineW, NumArgs);
except;
end;
if TempArgs <> nil then
begin
SetLength(ParamStrW, NumArgs^); // * SetLength(ParamStrW, NumArgs);
ParamCountW := NumArgs^ - 1; // * ParamCountW := NumArgs - 1;
try
for i := 0 to NumArgs^ - 1 do // * for i := 0 to NumArgs - 1 do
ParamStrW[i] := TPWideCharArray(TempArgs^)[i];
except;
end;
try;
LocalFree(THandle(TempArgs)); // * Fixme: pointer conversion not portable
except;
end;
end;
if ParamCount > ParamCountW then
begin
SetLength(ParamStrW, ParamCount + 1);
for i := ParamCountW + 1 to ParamCount do
ParamStrW[i] := WideString(ParamStr(i));
ParamCountW := i; // *
end;
if ParamCountW < 3 then
begin
writeln('Insufficient command line parameters !'); // *
writeln( // *
'Please use "[USB_drive_number] [WaitTime] [QEMUexe] [QEMU_parameters]"');
writeln('Press Enter to continue ...'); // *
readln; // *
// MessageBox(0, 'Insufficient command line parameters !'#13#10 +
// 'Please use "[USB_drive_number] [WaitTime] [QEMUexe] [QEMU_parameters]"',
// 'Warning', MB_OK or MB_ICONWARNING);
Exit;
end;
udn := Min(Max(StrToIntDef(ansistring(ParamStrW[1]), 1), 0), 99);
WaitTime := Min(Max(StrToIntDef(ansistring(ParamStrW[2]), 500), 1), 10000);
ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
SetLength(VolLet, 0);
for i := byte('C') to byte('Z') do
begin
case GetDriveType(PChar(char(i) + ':\')) of
DRIVE_REMOVABLE, DRIVE_FIXED:
begin
try
hVolume := CreateFile(PAnsiChar('\\.\' + char(i) + ':'),
0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
except
hVolume := INVALID_HANDLE_VALUE;
end;
if hVolume <> INVALID_HANDLE_VALUE then
begin
dwBytesReturned := 0;
if DeviceIoControl(hVolume, IOCTL_STORAGE_GET_DEVICE_NUMBER,
nil, 0, @sdn, sizeof(sdn), dwBytesReturned, nil) then
if sdn.DeviceNumber = cardinal(udn) then
begin
SetLength(VolLet, Length(VolLet) + 1);
VolLet[High(VolLet)] := char(i);
end;
end;
end
else
Continue;
end;
end;
SetErrorMode(ErrorMode);
SetLength(VolumesHandles, 0);
for i := 0 to High(VolLet) do
begin
FlushToDisk(VolLet[i]);
Sleep(WaitTime);
if not DisMountVolume(VolLet[i]) then
begin // *
writeln('Unable to dismount volume ''' + VolLet[i] + ''' !'); // *
writeln('Possible reason: ' + SysErrorMessage(LastError)); // *
writeln('Press Enter to continue ...'); // *
readln; // * Fixme: Check answer 'y'/'Y' to continue instead of exiting
// if MessageBox(0, PChar('Unable to dismount volume ''' +
// VolLet[i] + ''' !'#13#10'Possible reason: ' +
// SysErrorMessage(LastError) +
// #13#10'Are you sure you want to continue...?'), PChar('Warning'),
// MB_YESNO or MB_ICONWARNING or MB_DEFBUTTON2) = mrNo then
Exit;
end; // *
end;
ComLine := '';
for i := 3 to ParamCountW do
ComLine := ComLine + '"' + ParamStrW[i] + '" ';
GetStartUpInfo(StartInfo);
StrPCopyW(zAppName, ComLine);
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := StartInfo.dwFlags;
StartupInfo.wShowWindow := StartInfo.wShowWindow;
// QFolder := WideExtractFilePath(ParamStrW[3]);
QFolder := ExtractFilePath(ParamStrW[3]); // *
if QFolder <> '' then
PQFolder := PWideChar(QFolder)
else
PQFolder := nil;
if CreateProcessW(nil, zAppName, nil, nil, False,
// CREATE_NEW_CONSOLE or HIGH_PRIORITY_CLASS, * this is not the QEMU process
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
nil, PQFolder, Windows.StartupInfoW(StartupInfo), ProcessInfo) then
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Res);
FileClose(ProcessInfo.hProcess); // * CloseHandle (ProcessInfo.hProcess);
FileClose(ProcessInfo.hThread); // * CloseHandle(ProcessInfo.hThread);
end
else
begin // *
writeln('Unable to launch QEMU !');
writeln('Press Enter to continue ...');
readln;
// ShowMessage('Unable to launch QEMU !');
end; // *
for i := 0 to High(VolumesHandles) do
try
FileClose(VolumesHandles[i]); // * CloseHandle(VolumesHandles[i]);
except;
end;
end.
I would have preferred to post this long code as attachment in a ZIP archive, together with the binary, but I do not see an uploader button. Since I let the error messages go to the console, not to a message box, there is no need to link GUI units any longer, and the binary shrinks to 230 KiB.
(which in this case means bad 
)
