Mega Code Archive
Turbo Pascal Compatibility DOS
<![CDATA[
Title: Turbo Pascal Compatibility: DOS
A DOS unit for Delphi, which should give some TP compatibility, which hopefully all should work, save the issues. Again if anything is not implemented, either it wasn't a good idea, or I didn't know how (I included empty function prototypes and the relevant data types).
The big standing issue: NTFS drives seem to not store short file names for everything, which means you can not get compatible SFNs for all files in the system. In that case, you will get LFNs returned, which may or may not be what your program is ready for (I defined the SearchRec record to have a String type instead of String[12] like the original). Double-check your program if you use FindFirst/FindNext to see if this won't be a problem.
Hope this helps someone, if not by its direct use, to see how to do something from the DOS unit in Delphi/Win32.
CODE
unit dos;
{ unit for DOS functions in Delphi - coded by Glenn9999 under Delphi 3. Used helps from
the Internet for Turbo Pascal references and the Free Pascal sources. }
interface
uses sysutils, windows;
const
{ file attribute constants }
ReadOnly = faReadOnly;
Hidden = faHidden;
SysFile = faSysFile;
VolumeID = faVolumeID;
Directory = faDirectory;
Archive = faArchive;
AnyFile = faAnyFile;
type
Int64 = Comp; { comment out if you have Int64 type }
{ data types and records that were defined in the DOS unit }
PathStr = String[79];
DirStr = String[67];
NameStr = String[8];
ExtStr = String[4];
ComStr = string[128];
{ used for PackTime and UnPackTime }
DateTime = record
Year, Month, Day, Hour, Min, Sec: Word;
end;
{ searchrec type. Changed in certain respects to ease functionality
in Windows, since the exact record format shouldn't matter too much
as long the record is not accessed directly, as opposed to access by
the record type definition. Also, NTFS file systems do not necessarily
store and return short file names, so you may get LFNs out of FindFirst
if run against such systems.
- check your TP program before you try using FindFirst }
SearchRec = record
Attr: Byte; { attribute of file returned }
Time: Longint; { packed timestamp }
Size: Longint; { size of file }
Name: string; { name of file (short name if available }
{ variables following are necessary for continued functionality
of findfirst/FindNext }
FindHandle: THandle; { saved search handle }
ExcludeAttr: Integer; { saved attribute parm }
Path: PathStr; { saved path parm }
end;
Registers = record { for the do-nothing calls }
case Integer of
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
end;
var
doserror: integer;
DosExitCode: DWord;
{ these two functions are not in the DOS unit, but are here if needed,
otherwise the regular functions as defined in the DOS unit will only
report a maximum of 2GB. }
function DiskSizeEx(Drive: Byte): Int64; // addl functions added
function DiskFreeEx(Drive: Byte): Int64; // these work for 2GB
function fexpand(filename: string): string;
procedure GetFAttr(var f; var attr: word);
procedure SetFAttr(var F; Attr: Word);
procedure FSplit(Path: PathStr; var Dir: DirStr;
var Name: NameStr; var Ext: ExtStr);
procedure PackTime(var T: DateTime; var P: Longint);
procedure UnpackTime(P: Longint; var T: DateTime);
procedure FindFirst(Path: PathStr; Attr: Word; var F: SearchRec);
procedure FindNext(var F: SearchRec);
function DiskFree(Drive: Byte): Longint;
function DiskSize(Drive: Byte): Longint;
function DosVersion: Word;
function FSearch(Path: PathStr; DirList: String): PathStr;
procedure GetFTime(var F; var Time: Longint);
procedure SetFTime(var F; Time: Longint);
procedure GetDate(var Year,Month,Day, DayOfWeek: Word);
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
procedure SetDate(Year,Month,Day: Word);
procedure SetTime(Hour,Minute,Second,Sec100: Word);
function EnvCount: Integer;
function EnvStr(Index: Integer): String;
function GetEnv(EnvVar: String): String;
procedure Exec(Path: PathStr; ComLine: ComStr);
{ do nothing functions - generally incompatible for Windows, included
here both for documentation and to not break compilation of programs
that might not otherwise work. }
procedure GetVerify(var Verify: Boolean);
procedure Intr(IntNo: Byte; var Regs: Registers);
procedure Keep(ExitCode: Word);
procedure MsDos(var Regs: Registers);
procedure GetCBreak(var Break: Boolean);
procedure SetCBreak(Break: Boolean);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
procedure SetVerify(Verify: Boolean);
procedure SwapVectors;
{ crossover DOS unit, allows some functions to go through sysutils unit }
implementation
uses messages;
{ ***********************************************************************
Service functions for the other functions listed in the interface unit
*********************************************************************** }
function GetShortName(sLongName: string): string;
begin
Result := sLongName;
end;
function getvolname(input: string): string;
{ returns Volume Name of the drive that is inputted
adapted from http://www.delphicorner.f9.co.uk/articles/wapi2.htm
MAX_PATH is a dword defined to be 260 }
var
nVNameSer: PDWORD;
pVolName: PChar;
FSSysFlags, maxCmpLen: DWord;
pFSBuf: PChar;
begin
GetMem(pVolName, MAX_PATH);
GetMem(pFSBuf, MAX_PATH);
GetMem(nVNameSer, MAX_PATH);
GetVolumeInformation(PChar(input), pVolName, MAX_PATH,
nVNameSer, maxCmpLen, FSSysFlags, pFSBuf,
MAX_PATH);
GetVolName := String(pVolName);
FreeMem(pVolName, MAX_PATH);
FreeMem(pFSBuf, MAX_PATH);
FreeMem(nVNameSer, MAX_PATH);
end;
function DiskFreeEx(Drive: Byte): Int64;
{ redone DiskFree function which reports amount free on a disk 2GB
- original from Delphi 3 sources, changed to increase size of
variable returned. Can be called if real size is necessary. }
var
RootPath: array[0..4] of Char;
RootPtr: PChar;
SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: Integer;
OutInt64: Int64;
begin
RootPtr := nil;
if Drive 0 then
begin
StrCopy(RootPath, 'A:\');
RootPath[0] := Char(Drive + $40);
RootPtr := RootPath;
end;
if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector,
FreeClusters, TotalClusters) then
begin
OutInt64 := SectorsPerCluster;
Result := OutInt64 * BytesPerSector * FreeClusters;
end
else
Result := -1;
end;
function DiskSizeEx(Drive: Byte): Int64;
{ redone DiskSize function which reports size of disk 2GB
- original from Delphi 3 sources, changed to increase size of
variable returned. Can be called if real size is necessary. }
var
RootPath: array[0..4] of Char;
RootPtr: PChar;
SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: Integer;
OutInt64: Int64;
begin
RootPtr := nil;
if Drive 0 then
begin
StrCopy(RootPath, 'A:\');
RootPath[0] := Char(Drive + $40);
RootPtr := RootPath;
end;
if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector,
FreeClusters, TotalClusters) then
begin
OutInt64 := SectorsPerCluster;
Result := OutInt64 * BytesPerSector * TotalClusters;
end
else
Result := -1;
end;
function ProcessAMsg: Boolean;
{ service function for ProcessMessage }
var
Msg: TMsg;
msg_proc: boolean;
begin
msg_proc := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
msg_proc := True;
if Msg.Message WM_QUIT then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
ProcessAMsg := msg_proc;
end;
procedure ProcessMessage;
{ this should be an equivalent to TApplication.ProcessMessages }
begin
while ProcessAMsg do;
end;
function os_is_nt: Boolean;
{ returns whether the OS is NT based or not }
var
osvinfo: TOsVersionInfo;
begin
{ get windows version }
osvinfo.dwOSVersionInfoSize := Sizeof(osvinfo);
GetVersionEx(osvinfo);
os_is_nt := (osvinfo.dwPlatformId = VER_PLATFORM_WIN32_NT);
end;
function NTSetPrivilege(sMachine, sPrivilege: string;
bEnabled: Boolean): Boolean;
{ set privilege on remote computer. Define sMachine to be null if you want
local machine. Modified from something on SwissCenter. }
var
hToken: THandle;
TokenPriv: TTokenPrivileges;
PrevTokenPriv: TTokenPrivileges;
ReturnLength: DWord;
begin
// Only for Windows NT/2000/XP and later.
if not (os_is_nt) then
begin
Result := true;
Exit;
end;
// obtain the processes token
if OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
try
// Get the locally unique identifier (LUID) .
if LookupPrivilegeValue(PChar(sMachine), PChar(sPrivilege),
TokenPriv.Privileges[0].Luid) then
begin
TokenPriv.PrivilegeCount := 1; // one privilege to set
case bEnabled of
True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
False: TokenPriv.Privileges[0].Attributes := 0;
end;
ReturnLength := 0; // replaces a var parameter
PrevTokenPriv := TokenPriv;
// enable or disable the privilege
AdjustTokenPrivileges(hToken, False, TokenPriv,
SizeOf(PrevTokenPriv), PrevTokenPriv, ReturnLength);
end;
finally
CloseHandle(hToken);
end;
end;
// test the return value of AdjustTokenPrivileges.
Result := GetLastError = ERROR_SUCCESS;
if not Result then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
{ ***********************************************************************
Dos Compatibility Functions listed after this point
*********************************************************************** }
function fexpand(filename: string): string;
{ returns the fully qualified path for a file }
var
test: string;
test_len: integer;
begin
// we need a string for ExpandFileName if there is not one
if filename = '' then filename := '*.*';
test := GetShortName(ExpandFileName(Filename));
{ check for trailing . - we want the path as TP returns,
not the base directory identifier as well }
test_len := length(test);
if test[test_len] = '.' then
begin
test := copy(test, 1, test_len-1);
dec(test_len, 1);
end;
// ExpandFileName returns *.* on the path. The TP FExpand did not.
if pos('\*.*', test) 0 then
test := copy(test, 1, test_len-4);
// if test[test_len] = '\' then
// test := test + '*.*';
fexpand := test;
end;
procedure GetFAttr(var f; var attr: word);
{ gets the file attribute for a file variable }
begin
doserror := 0;
attr := FileGetAttr(TFileRec(f).Name);
if attr = -1 then
doserror := GetLastError;
end;
procedure SetFAttr(var F; Attr: Word);
{ sets the file attribute for a file variable }
begin
doserror := 0;
doserror := FileSetAttr(TFileRec(f).Name, attr);
end;
procedure FSplit(Path: PathStr; var Dir: DirStr;
var Name: NameStr; var Ext: ExtStr);
{ splits a full file path into the directory, name, and extension }
var
filename: string;
begin
Path := GetShortName(Path);
Dir := ExtractFilePath(Path);
filename := ExtractFileName(Path);
Name := copy(filename, 1, pos('.', filename)-1);
Ext := ExtractFileExt(Path);
end;
procedure PackTime(var T: DateTime; var P: Longint);
{ datetime type to packed DOS Timestamp }
var
MSec: Word;
DateTime: TDateTime;
begin
MSec := 0;
With T Do
begin
DateTime := EncodeDate(Year, Month, Day) +
EncodeTime(Hour, Min, Sec, MSec);
end;
P := DateTimeToFileDate(DateTime);
end;
procedure UnpackTime(P: Longint; var T: DateTime);
{ Packed DOS Timestamp to datetime type }
var
MSec: Word;
MyDateTime: TDateTime;
begin
MyDateTime := FileDateToDateTime(p);
With T Do
begin
DecodeDate(MyDateTime, Year, Month, Day);
DecodeTime(MyDateTime, Hour, Min, Sec, MSec);
end;
end;
procedure move_sr(F: TSearchRec; var O: SearchRec);
{ moves information from TSearchRec to SearchRec }
begin
if F.FindData.cAlternateFileName '' then
O.Name := F.FindData.cAlternateFileName
else
O.Name := F.Name;
O.Size := F.Size;
O.Attr := F.Attr;
O.Time := F.Time;
O.FindHandle := F.FindHandle;
O.excludeattr := F.ExcludeAttr;
end;
procedure FindFirst(Path: PathStr; Attr: Word; var F: SearchRec);
{ revised FindFirst. TP returned volume attribute, so we must
handle that first, and return it first }
var
tempsr: TSearchRec;
return_volid: boolean;
expf: string;
begin
DosError := 0;
{ determine whether to return VolumeID }
return_volid := false;
if (Attr and VolumeID) = VolumeID then
begin
expf := ExpandFileName(Path);
if Copy(expf, 2, 5) = ':\*.*' then
return_volid := true;
end;
{ handle volume ID if it is called for }
if return_volid then
begin
F.name := GetVolName(expf[1] + ':\');
if F.name '' then { if there is a volumeID to return }
begin
if Length(F.Name) 8 then // format in the way DOS does
F.Name := Copy(F.name, 1, 8) + '.' + Copy(F.Name, 9, 20);
F.ExcludeAttr := Attr; { save attr }
F.Attr := VolumeID; { indicate VolumeID attr }
F.FindHandle := INVALID_HANDLE_VALUE; { have not opened FindFirst }
F.Path := Path; { store path }
end
else
if Attr = VolumeID then { if we are supposed to only return VolumeID}
DosError := 18;
end
else
begin { not supposed to return VolumeID }
DosError := SysUtils.FindFirst(Path, Attr, tempsr);
Move_SR(tempsr, F);
end;
end;
procedure FindNext(var F: SearchRec);
{ revised FindNext }
var
tempsr: TSearchRec;
begin
{ check if FindFirst actually called - i.e. first call was for
VolumeID }
if F.FindHandle = INVALID_HANDLE_VALUE then
begin
DosError := SysUtils.FindFirst(F.Path, F.ExcludeAttr, tempsr);
F.Path := '';
Move_SR(tempsr, F);
end
else
begin
tempsr.FindHandle := F.FindHandle;
tempsr.ExcludeAttr := F.ExcludeAttr;
DosError := SysUtils.FindNext(tempsr);
Move_SR(tempsr, F);
if DosError 0 then
SysUtils.FindClose(tempsr);
end;
end;
function DiskFree(Drive: Byte): Longint;
{ TP DOS unit compatible function. Calls the working Diskfree function
and then returns a maximum of 2GB. }
var
DF: Int64;
begin
DF := DiskFreeEx(Drive);
if DF MAXLONGINT then
Result := MAXLONGINT
else
Result := Trunc(DF);
end;
function DiskSize(Drive: Byte): Longint;
{ TP DOS unit compatible function. Calls the working DiskSize function
and then returns a maximum of 2GB. }
var
DS: Int64;
begin
DS := DiskSizeEx(Drive);
if DS MAXLONGINT then
Result := MAXLONGINT
else
Result := Trunc(DS);
end;
function DosVersion: Word;
{ uses Win32 version in same format as expected in DOS unit,
lo byte = major hi byte = minor. Values come from sysutils unit }
begin
DosVersion := (Win32MinorVersion shl 8) + Win32MajorVersion;
end;
function FSearch(Path: PathStr; DirList: String): PathStr;
{ searches for the Path in the Directory List given }
begin
FSearch := GetShortName(FileSearch(Path, DirList));
end;
procedure GetFTime(var F; var Time: Longint);
{ return file time. Takes file id and packed time }
begin
doserror := 0;
Time := FileGetDate(TFileRec(F).Handle);
if Time = -1 then
doserror := GetLastError;
end;
procedure SetFTime(var F; Time: Longint);
{ Set file time. Takes file id and packed time }
begin
doserror := 0;
FileSetDate(TFileRec(f).Handle, time);
doserror := GetLastError;
end;
function EnvCount: Integer;
{ returns the number of environment strings. Is resource-intensive,
be careful in calling this function }
var
Env1, Env2: PChar;
envi_count: integer;
begin
envi_count := 0;
Env1 := GetEnvironmentStrings;
Env2 := Env1;
if Env2 nil then
repeat
inc(Env2, StrLen(Env2) + 1);
inc(envi_count);
until Env2^ = #0;
FreeEnvironmentStrings(Env1);
EnvCount := envi_count;
end;
function EnvStr(Index: Integer): String;
{ returns an environment string with specific index.
Is resource-intensive, be careful in calling this function }
var
Env1, Env2: PChar;
envi_count: integer;
begin
envi_count := 1;
Env1 := GetEnvironmentStrings;
Env2 := Env1;
if Env2 nil then
while (envi_count index) and (Env2^ #0) do
begin
inc(Env2, StrLen(Env2) + 1);
inc(envi_count);
end;
EnvStr := StrPas(Env2);
FreeEnvironmentStrings(Env1);
end;
function GetEnv(EnvVar: String): String;
{ gets an environment string with a specific name }
var
PathName: PChar;
Buffer: array[0..255] of char;
begin
PathName := PChar(EnvVar);
GetEnvironmentVariable(PathName, @Buffer, Sizeof(Buffer));
GetEnv := String(Buffer);
end;
procedure Exec(Path: PathStr; ComLine: ComStr);
{ executes a program, and waits for completion }
var
StartInfo : TStartupInfo;
ProcInfo : TProcessInformation;
CreateOK : Boolean;
ErrorCode : DWord;
AppDone : DWord;
begin
ErrorCode := 0;
FillChar(StartInfo,SizeOf(TStartupInfo),#0);
FillChar(ProcInfo,SizeOf(TProcessInformation),#0);
StartInfo.cb := SizeOf(TStartupInfo);
CreateOK := Windows.CreateProcess(nil,
PChar(String(Path) + ' ' + String(ComLine)),
nil, nil, False,
CREATE_NEW_PROCESS_GROUP+IDLE_PRIORITY_CLASS+SYNCHRONIZE,
nil, nil, StartInfo, ProcInfo);
WaitForInputIdle(ProcInfo.hProcess, INFINITE);
if CreateOK then
repeat
AppDone := WaitForSingleObject(ProcInfo.hProcess, 10);
ProcessMessage;
until AppDone WAIT_TIMEOUT;
CloseHandle(ProcInfo.hProcess);
CloseHandle(ProcInfo.hThread);
GetExitCodeProcess(ProcInfo.hProcess, ErrorCode);
DosExitCode := GetLastError;
end;
procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
{ returns the system date }
var
MySystemTime: TSystemTime;
begin
GetLocalTime(MySystemTime);
with MySystemTime do
begin
Year := wYear;
Month := wMonth;
Day := wDay;
DayOfWeek := wDayOfWeek;
end;
end;
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
{ returns the system time }
var
MySystemTime: TSystemTime;
begin
GetLocalTime(MySystemTime);
with MySystemTime do
begin
Hour := wHour;
Minute := wMinute;
Second := wSecond;
Sec100 := wMilliseconds;
end;
end;
procedure SetDate(Year,Month,Day: Word);
{ sets the system date }
const
SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
var
MySystemTime: TSystemTime;
begin
GetLocalTime(MySystemTime);
NTSetPrivilege('',SE_SYSTEMTIME_NAME, true);
with mysystemtime do
begin
wYear := Year;
wMonth := Month;
wDay := Day;
end;
SetLocalTime(MySystemTime);
NTSetPrivilege('',SE_SYSTEMTIME_NAME, false);
end;
procedure SetTime(Hour,Minute,Second,Sec100: Word);
{ sets the system time }
const
SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
var
MySystemTime: TSystemTime;
begin
GetLocalTime(MySystemTime);
NTSetPrivilege('',SE_SYSTEMTIME_NAME, true);
with mysystemtime do
begin
wHour := Hour;
wMinute := Minute;
wSecond := Second;
wMilliseconds := Sec100;
end;
SetLocalTime(MySystemTime);
NTSetPrivilege('', SE_SYSTEMTIME_NAME, false);
end;
{ ***********************************************************************
do nothing functions follow. These are things that were in the DOS unit,
but do not have any applicability to Windows (or were not implemented yet
in this unit for some reason) - they are included more for
compatibility than functionality
*********************************************************************** }
procedure GetVerify(var Verify: Boolean);
{ do nothing function}
begin
end;
procedure Intr(IntNo: Byte; var Regs: Registers);
{ do nothing function}
begin
end;
procedure Keep(ExitCode: Word);
{ do nothing function}
begin
end;
procedure MsDos(var Regs: Registers);
{ do nothing function}
begin
end;
procedure GetCBreak(var Break: Boolean);
{ do nothing function}
begin
end;
procedure SetCBreak(Break: Boolean);
{ do nothing function}
begin
end;
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
{ do nothing function}
begin
end;
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
{ do nothing function}
begin
end;
procedure SetVerify(Verify: Boolean);
{ do nothing function}
begin
end;
procedure SwapVectors;
{ do nothing function}
begin
end;
end.
]]>