{**********************************************************************
 ***                                                                ***
 ***                      WINDOW OS FUNCTIONS                       ***
 ***                                                                ***
 **********************************************************************}
{the various xxxfunc units, ie dosfunc and winfunc, are meant to provide
similar functions for the different running environments, in a similar
way that tuiapp provides a text alternative to winapp}
{$I compdirs}  {for single user flag}
unit WinFuncs;

INTERFACE

uses	objects,windos, dattime;

const
	{run types}
	rnNone = $00;
	rnCheck = $01;

{Running Other programs}
function Run(PRog, Parameters : string; rnType : word; Message : string) : word;  {Call a program with parameters}
function DOSCommand(s : string; rnType : word) : word;            {Call COMMAND.COM}
procedure DosShell;

{File Maintenance}
procedure DeleteFile(const FileName : FNameStr);
function FileExists(const FileName : FNameStr) : boolean;
procedure RenameFile(OldName, NewName : FNameStr);
procedure CopyFile(OldName, NewName : FNameStr);

{File functions}
function SizeFile(FileName : FNameStr) : longint;

{Path funcs}
procedure SetCurrentDirectory(DirName : string);
function GetCurrentDirectory : string;
function  ChkEndSlash(S : string) : string;
procedure CheckPath(var S : string);
function ValidPath(var S : string) : boolean;

function GetFileName(S : string) : string; {returns name from drive:path\name}
function GetJustFileName(S : string) : string; {returns name w/o ext from drive:path\name}
function GetPath(S : string) : string; {returns path from drive:path\name}
function GetExt(S : string) : string; {returns path from drive:path\name}

procedure GetFileDate(FileName : string; var Date : TDate; var Time : TTime);

function EmptyFileName(const FIleName : FNameStr) : boolean;

type
	{ DOS interrupt record structure for getting disk info}
	TInfoBuffer = record
		InfoLevel    : Word;
		SerialNumber : Longint;
		VolumeLabel  : array[1..11] of Char;
		FileSystem   : array[1..8]  of Char;
	end; { TInfoBuffer }

function GetDiskInfo(Drive: Char; var InfoBuffer: TInfoBuffer): Boolean;

var
	LastDOSFuncResult : word;
	DosVer : single;

IMPLEMENTATION

uses
			winmsgs,
{			scodes, {unload unused ones for shell - commented out June 94 due to circular "uses" problems}
			strings, {coping with nul-terminated strings that dos interrupts use}
			minilib,
			winprocs,   {for dpmi interrupts}
			messtext,
			files; {stxxx constants}


const
	XCopyExitMess : array[1..5] of pchar
													= ('No Files Found',
															'Ctrl-C Pressed',
															'',
															'Low memory?',
															'Disk write error');
	BackupRestoreExitMess : array[1..4] of PChar
													= ('No Files Found',
															'File-share conflicts',
															'Ctrl-C Pressed',
															'Error (DOS Ver?)');


function EmptyFileName(const FIleName : FNameStr) : boolean;
begin
	if (FileName = nil) or (FIleName[0]='.') then
		EmptyFileName := True
	else
		EmptyFileName := false;
end;

{*****************************************************************
 ***                                                           ***
 ***               INTERRUPTS                                  ***
 ***                                                           ***
 *****************************************************************}
const
	VideoInt        = $10;
	ClockInt        = $1C;
	TimerInt        = ClockInt;
	DOSInt          = $21;
	DPMIInt         = $31;
	KeyboardInt     = 9;
	MouseInt        = $33;

	GetRMIntVec     = $200;
	SetRMIntVec     = $201;
	GetFaultHandler = $202;
	SetFaultHandler = $203;

	SimIntr         = $300;
	CallFarRealProc = $301;
	CallIntRealProc = $302;
	AllocRMCallBack = $303;
	FreeRMCallBack  = $304;

	GetDiskSerialNo = $6900;

{not sure why this is all needed but anyway, see the problem solver guide}
type
	{ Used when dealing with GlobalDOSAlloc }
	ProtAddress = record
		Selector, Segment: Word;
	end; { ProtAddress }

	TRealRegs = record
		case Byte of
			0: (EDI, ESI, EBP, ERes, EBX, EDX, ECX, EAX: Longint;
					Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
			1: (DI, DIH, SI, SIH, BP, BPH, EResL, EResH: Word;
					case Byte of
						0: (BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
						1: (BL, BH, BLH, BHH, DL, DH, DLH, DHH,
								CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
	end; { TRealRegs }


function DPMISimIntr(IntNo: Byte; var Regs: TRealRegs): Boolean; assembler;
asm
	mov ax, SimIntr
	mov bl, IntNo
	mov bh, 0
	mov cx, 0
	les di, Regs
	int DPMIInt
	mov ax, 1
	jnc @Exit
	mov ax, 0
@Exit:
end; { DPMISimIntr }




{******************************************************************
 ***                    GET DISK INFO                           ***
 ******************************************************************}

function GetDiskInfo(Drive: Char; var InfoBuffer: TInfoBuffer): Boolean;
var
	Regs : TrealRegs;
	Address: ProtAddress;
	Success: Boolean;
	Result: Longint;
begin
	{---- DPMI Mode -----}
	GetDiskInfo := False;
	{ Allocate some real mode memory }
	Result := GlobalDosAlloc(SizeOf(InfoBuffer));
	if Result = 0 then
		Exit;
	Address := ProtAddress(Result);
	FillChar(Regs, SizeOf(Regs), 0);
	with Regs do
	begin
		AX := GetDiskSerialNo;
		BX := Ord(Drive) - 64;
		DS := Address.Segment;
		DX := 0;
	end;
	Success := DPMISimIntr(DosInt, Regs);
	{ Save the returned data }
	Move(Ptr(Address.Selector, 0)^, InfoBuffer, SizeOf(InfoBuffer));
	{ Tidy up }
	GlobalDosFree(Address.Selector);
	if not Success then
		Exit;
	GetDiskInfo := True;
end; { GetDiskInfo }



{======= SHARE CHECKING ==========================}
{From 1.18 of the Borland Pascal Problem solver}
function IsShareLoaded : boolean;
var
	F : file of word;
	Data : word;
	ShareNotLoaded : boolean;

begin
	Assign(F, 'temp.$$$');
	Rewrite(F);
	Write(F, data);
	asm
		mov ShareNotLoaded, True
		{$IFDEF Windows}
			mov bx, TFileRec(F).Handle
		{$ELSE}
			mov bx, FileRec(F).Handle
		{$ENDIF}
		mov cx, 0
		mov dx, 0
		mov si, 0
		mov di, 1
		mov al, 0
		mov ah, $5C
		int $21
		jc @@NoError
		dec ShareNotLoaded
		@@NoError:
	end;
	IsShareLoaded := not ShareNotLoaded;
	Close(F);
	Erase(F);
end;


{*************************************************
 ***             FILE CONTROL BLOCK            ***
 *************************************************}
{Processes using FCB's only work in current directory, so unused}
{type
	TFCB = object
		Drive : byte;
		FileName : array[1..8] of char;
		Ext : array[1..3] of char;
		BlockNo : word;
		RecordSize : word;
		FileSize : dword;
		Date : word;
		Time : word;
		Reserved : Qword;
		CurrentRecordNum : byte;
		RandomRecordNum : dword;

		procedure SetFileName(FileName : string);

	end;

procedure TFCB.SetFileName;
begin
end;
						{}


function GetFileName;
begin
	while pos('\',S)>0 do S := Copy(S,pos('\',S)+1,255); {chop out up to \'s}
	while pos(':',S)>0 do S := Copy(S,pos(':',S)+1,255); {chop out colons}
	GetFileName := S;
end;

function GetJustFileName;
begin
	S := GetFileName(S);
	if pos('.',S)>0 then S := Copy(S,1,pos('.',S)-1);
	GetJustFileName := S;
end;

function GetPath;
begin
	GetPath := Copy(S, 1, length(S)-length(GetFileName(S))); {all of string minus file name...}
end;

function GetExt;
begin
	if pos('.',S)=0 then
		GetExt := ''
	else
		GetExt := Copy(S, pos('.',S)+1, length(S)); {from period onwards}
end;


function ChkEndSlash(S : string) : string;
begin
	if (S<>'') and (S[length(S)] <> '\') then ChkEndSlash := S + '\' else ChkEndSlash := S;
end;



procedure CheckPath(var S : string);
begin
	if not ValidPath(S) then begin
		ProgramWarning('Path '+S+' invalid');
		S := '';
	end;
end;


function ValidPath;
var CheckFile : Text;
		LastIOResult : integer;
		FileName : PChar;
begin
{$I-}
	ValidPath := True;
	if S <> '' then begin
		GetMem(FileName, length(S)+9);
		StrPCopy(FileName, S+'TESTPATH');
		assign(CheckFile,FileName);
		rewrite(CheckFile);
		if IOResult<>0 then
			ValidPath := False {not ok}
		else begin
			close(CheckFile);
			DeleteFile(FileName); {was OK, so delete test file}
		end;{}
		FreeMem(FIleName, length(S)+9);

		{Note that this method does not work on Novell networks, as Novell
		directories do not have a . or a .. file}
{$I-}
{		Assign(CheckFile, S+'.');
		Reset(CheckFile);{}
{$I+}
{		LastIOResult := IOResult; {store & clear}

{		if LastIOResult = 3 then {path not found}
{			ValidPath := False
		else begin
			ValidPath := True;
			if LastIOResult=0 then close(CheckFile);
		end; {}
	end;
end;

{*****************************************
 **             FILE FUNCS             ***
 *****************************************}
{===== SIZE FILE ===========}
function SizeFile;
var	SFile : file of byte;
		LastIOResult : integer;
begin
{$I-}
	{Open file for sizing & to test that it exists}
	Assign(SFile, FileName);  {Open ready for sizing}
	Reset(SFile);

	{Check to see if file opened OK}
	LastIOResult := IOResult;
	if (LastIOResult<>0) then begin
		SizeFile := -LastIOResult;
		exit;
	end;

	SizeFile := filesize(SFile);           {Size it}
	close(SFile);
{$I+}
end;

{*****************************************
 **             DOS SHELL              ***
 *****************************************}
{User shell out to Dos}
procedure DosShell;
begin
{	if Desktop <> nil then PApplication(Desktop^.Owner)^.DosShell {use given one if it's there - less memory reqd}
{	else} DOSCOmmand('',rnNone);
end;


{*****************************
 ***     RUN PROGRAM       ***
 *****************************}

function Run(Prog, Parameters : string; rnType : word; Message : string) : word;
var
 DosExit : word;
 DosErr : word;
	BufferSize : longint;
	ErrS : string;

begin
{	UnloadUnusedSCodes;{Commented out for now due to circular "uses" problems - June 94}
	if pos('.BAT',ucase(Prog))>0 then begin
		Run := DOSCommand(Prog+' '+Parameters, rnType);
		exit;
	end;

	DoneSysError;
	DoneEvents;
	DoneVideo;
	DoneDosMem;  {releases all cash buffers and minimises heap}
	SwapVectors;

	writeln(Message);

	WinExec(Prog, Parameters);             {Execute program - needs complete segment to start}

	SwapVectors;
	InitDosMem;

	if (rnType and rnCheck)>0 then begin
		writeln('');
		writeln('Done. Please check messages and press any key');
		DoneBleep;
		repeat until Keypressed;
	end;

	InitVideo;
	InitEvents;
	InitSysError;

	if (Desktop<> nil) and (Desktop^.Owner<>nil) then Desktop^.Owner^.Redraw;

	{Check DosError field}
	DosErr := DosError;									{Store 'cos it gets cleared}
	Run := DosErr; {return to caller}

	if rnType = rnCheck then begin
		if (DosErr<>0) then ProgramWarning('DOS ERROR: '+IOError(DosErr)+#13#10
																+Prog+' '+Parameters);

		{Check dos exit code}
		DosExit := DosExitCode;             {Store 'cos I think it gets cleared}
		if (DosExit>0) then begin
			ErrS := 'DOS EXIT CODE $'+hex(DosExit)+' ';

			if pos('XCOPY',ucase(Prog))>0 then ErrS := ErrS + XCopyExitMess[DosExit]^;
			if (pos('BACKUP',ucase(Prog))>0)
				or (pos('RESTORE',ucase(Prog))>0) then ErrS := ErrS + BackupRestoreExitMess[DosExit]^;

			ProgramWarning(ErrS+#13#10+Prog+'  '+Parameters);
			Run := DosExit;
		end;
	end;

end;


function DOSCommand(s : string; rnType : word) : word;
var ComSpec : string;
		Message : string;

begin
	ComSpec := GetEnv('COMSPEC');
	if ComSpec = '' then ComSpec := 'C:\COMMAND.COM';

	if S<>'' then Message := 'Executing '+S+'...' else Message := '';

	if S <>'' then S := ' /C '+S;         {If a command asked for, put /C execute on}
	DOSCommand := Run(ComSpec, S, rnType, Message);          {Execute DOS COMMAND with command in S}
end;




{******************************************
 *** FILE FUNCTIONS - MSDOS INTERRUPT   ***
 ******************************************}
{=============== DELETE FILE ====================}
procedure DeleteFile;
var
	Regs: TRegisters;

begin
	{Calls interrupt $21 - msdos - with $41 - delete file (handle)}
	{see p631 of the DOS Programmers reference, and p261}

	regs.ah := $41;   {delete file}

{	msdos(regs);{}

	LastDOSFuncResult := Regs.AX;
	{Should check return codes}
end;

{=============== CHECK FOR FILE ====================}
function FileExists;
var CheckFile : text;
		LastIOResult : integer;

begin
{$I-}
	Assign(CheckFile, FileName);
	Reset(CheckFile);
{$I+}
	LastIOResult := IOResult; {store & clear}

	if (LastIOResult = 2) or (LastIOResult = 3) then
		{Not there}
		FileExists := False
	else begin
		FileExists := True;
		if LastIOResult=0 then close(CheckFile);
	end;

end;

{=================== RENAME FILE ====================}
{needs to be in default directory}
procedure RenameFile;
var F : text;
begin
	Assign(F, OldName);
	Rename(F, NewName);
end;

{====================== COPY FILE =====================}
{Uses Turbovisions streaming methods}

{Doesn't always seem reliable - problem perhaps with getsize?}

procedure CopyFile;
var OldStream, NewStream : PDosStream;

begin
	DosCommand('COPY '+OldName+' '+NewName,rnNone);

{	New(OldStream, init(OldName, stOpenShare));
	New(NewStream, init(NewName, stOpenShare));
	OldStream^.Seek(0);
	NewStream^.Seek(0); {set both to start}
{	NewStream^.Truncate; {otherwise method below just overwrites first bit, not replacing whole thing}
{	NewStream^.CopyFrom(OldStream^, OldStream^.GetSize); {copy complete stream}
{	dispose(OldStream, done);
	dispose(NewStream, done);{}
end;


{=============== SET DEFAULT DIRECTORY ====================}
procedure SetCurrentDirectory;
var
	Regs: TRegisters;

begin
	{Calls interrupt $21 - msdos - with $3B - Set Directory
	{see p622 of the DOS Programmers reference}

	regs.ah := $3B;   {set dir}

	regs.ds := seg(DirName);
	regs.dx := ofs(DirName);   {bypass first - length - byte}

	msdos(regs);

	LastDOSFuncResult := Regs.AX;

	{Should check return codes}
end;

{=============== GET DEFAULT DIRECTORY ====================}
function GetCurrentDirectory;
var
	Regs: TRegisters;
	Dir : PChar;

begin
 {Calls interrupt $21 - msdos - with $47 - Get Directory
 {see p662 of the DOS Programmers reference}

 regs.ah := $47;   {get dir}

 regs.dl := 0;			{default drive}

 regs.ds := seg(Dir);
 regs.dx := ofs(Dir);

 msdos(regs);

	LastDOSFuncResult := Regs.AX;{}

	if Regs.AX<>$F then {invalid drive}
		{Dir is simply a "scratch buffer" - nul terminated string}
		GetCurrentDirectory := '\'+StrPas(Dir)
	else
		GetCurrentDirectory := '';

end;

{================ SET NUMBER OF FILE HANDLES ===============}
procedure SetNumFileHandles;
var
	Regs: TRegisters;
begin
	Regs.AH := $67;  {Set handle count - see p712 DOS programmers ref}
	Regs.BX := Num;  {Set number of handles desired}

	msdos(regs);

	LastDOSFuncResult := Regs.AX;

	{Check for errors}
	if (Regs.Flags and $01)>0 then begin
		{check carry flag - This seems to be the one}
		ProgramWarning('Error setting #File Handles='+N2Str(Num)+#13#10+'Regs.AX='+IOError(Regs.AX));
		{no handles by default 20 so no point in setting to less than that}
		if (Regs.AX = 8) and (Num>=40) then SetNumFileHandles(Num div 2); {try again with less}
	end;
end;

{***********************************************
 ***             GET FILE'S DATE             ***
 ***********************************************}
procedure GetFileDate;
var	F : text;
		ftime : Longint; { For Get/SetFTime}
		{$IFDEF Windows}
			dt : TDateTime; { For Pack/UnpackTime }
		{$ELSE}
			dt : DateTime;
		{$ENDIF}
		LastIO : integer;

begin
	Date.Clear;
{$I-}
	Assign(F, FileName);
	reset(F); {don't rewrite - it may be in use}
	LastIO := IOResult;

	if LastIO = 0 then begin
		GetFTime(F,ftime); { Get creation time }
		LastIO := IOREsult;
		if LastIO = 0 then begin
			UnpackTime(ftime,dt);

			with dt do begin
				Date.SetToNum(Day, Month, Year);
				Time.SetToNum(Hour, Min, Sec);
			end;

		end else
			ProgramWarning('Could not date file '+Filename+#13#10+IOError(LastIO));

		Close(f);   { Close file }

	end else
		ProgramWarning('Could not open file '+Filename+' for dating'+#13#10+IOError(LastIO));
{$I+}
end;



begin
{$IFDEF fixit}	write('WinFuncs...'); {$ENDIF}

	{get dos version & store in single format so easy to check}
	DosVer := hi(DosVersion) + (lo(DosVersion)/10);

	{$IFDEF fixit} writeln('...done'); {$ENDIF}
end.
