PRG48 - Отдача таймслайсов. Паскаль с ассемблеpом.

[FAQServer]

[Q]: Отдача таймслайсов. Паскаль с ассемблеpом.

[A]: Vadim Rumyantsev (2:5030/301)

Более новая веpсия с пофиксенным зависанием пpи pедком стечении обстоятельств
в полночь в ДОСе :) И ещё чyть-чyть список опеpационных систем pасшиpен.

──────────────────────────────────[Cut Here]──────────────────────────────────

{ Written by Vadim Rumyantsev, 2:5030/301. }
{ Generic DELAY unit -- release timeslices }
{ if under OS/2 2.0, Windows 3.0, DesqView, }
{ DoubleDOS and probably DOS 5.0 (?!), else }
{ do nothing. }
{ It is assumed that program receives time }
{ quantums every day... so, don't run this }
{ unit on slow systems! ;-) }
{ Virtual Pascal compatible now! }
{ Delphi 2.0 compatible now. }
{ You may use this **without restrictions** }



UNIT USLDelay;

{$I-}

INTERFACE



type
OS_Type = (OS_MSDOS, OS_DOUBLEDOS, OS_TOPVIEW, OS_DESQVIEW,
OS_OS2_1, OS_OS2_2, OS_WINDOWS, OS_WIN32, OS_MACOS);

const
AccessDenied : set of byte = [5 {$IFNDEF DOS} , 32 {$ENDIF} ];

var
Running_OS_Name : string;

{$IFDEF OS2}
const
Running_OS = OS_OS2_2;
{$ENDIF}
{$IFDEF WIN32}
const
Running_OS = OS_WIN32;
{$ENDIF}
{$IFDEF MSDOS}
var
Running_OS : OS_Type;
{$ENDIF}
{$IFDEF DPMI}
var
Running_OS : OS_Type;
{$ENDIF}


procedure Delay (n : longint);



IMPLEMENTATION

{$IFDEF OS2}

uses {$IFDEF VIRTUALPASCAL} Os2base {$ELSE} Doscalls {$ENDIF};

var
Buf : packed array [5..12] of longint;
Sgn : string;
f : file;
fp : longint;
sp : longint;
p1, p2 : integer;

{$ENDIF}

{$IFDEF WIN32}

uses SysUtils, Windows;

const
UnknownPlatform = 'Win32';
UnknownWin95 = 'Win9x';

var
VersionInfo : TOsVersionInfoA;
vb : string [10];

{$ENDIF}

{$IFDEF MSDOS}

uses Dos;

{ Define Seg0040 for backward compatibility with TP 4.0 .. TP 6.0 }

const
Seg0040 = $0040;


var
r : Registers;
dosvh, dosvl : byte;
osvh, osvl : byte;
vendor : string [3];

{$DEFINE DOSMODE}

{$ENDIF}

{$IFDEF DPMI}

uses Dos;

{ Define Seg0040 for backward compatibility with TP 4.0 .. TP 6.0 }

var
r : Registers;
dosvh, dosvl : byte;
osvh, osvl : byte;
vendor : string [3];

{$DEFINE DOSMODE}

{$ENDIF}


function Version (vh, vl : longint) : string;

var
vhs, vls : string [2];

begin

str (vh, vhs);
str (vl, vls);
if length (vls) = 1 then
vls := '0' + vls;
if vls [length (vls)] = '0' then
dec (vls [0]);
Version := vhs + '.' + vls

end;


{$IFDEF OS2}

procedure Delay;

begin

if DosSleep (n) <> 0 then;

end;

BEGIN

Running_OS_Name := 'OS/2';

if DosQuerySysInfo (5, 12, Buf, sizeof (Buf)) = 0 then begin

FileMode := open_access_ReadOnly + open_share_DenyNone;
assign (f, chr (64 + Buf [5]) + ':\OS2KRNL');
reset (f, 1);
seek (f, $3C);
blockread (f, fp, 4);
seek (f, fp+$88);
blockread (f, fp, 4);
seek (f, fp);
blockread (f, Sgn [0], 1);
blockread (f, Sgn [1], length (Sgn));
p1 := pos ('@#', Sgn);
p2 := pos ('#@', Sgn);
if (IoResult = 0) and
(p1 <> 0) and (p2 <> 0) and (p2 > (p1+2))
then begin
Sgn := copy (Sgn, p1+2, p2-p1-2);
p1 := pos (':', Sgn);
if p1 <> 0 then
Sgn := copy (Sgn, p1+1, 255);
Running_OS_Name := Running_OS_Name + ' Revision ' + Sgn
end
else begin
Buf [11] := Buf [11] div 10;
if (Buf [11] = 2) and (Buf [12] >= 30) and (Buf [12] < 90) then begin
Buf [11] := Buf [12] div 10;
Buf [12] := Buf [12] mod 10
end;
Running_OS_Name := Running_OS_Name + ' ' + Version (Buf [11], Buf [12])
end;

close (f);
if IoResult <> 0 then;

end;

{$ENDIF}


{$IFDEF WIN32}

procedure Delay;

begin

Sleep (n);

end;

BEGIN

with VersionInfo do begin
dwOsVersionInfoSize := sizeof (VersionInfo);
if not GetVersionExA (VersionInfo) then
Running_OS_Name := UnknownPlatform
else begin
str (dwBuildNumber and $FFFF, vb);
case dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
if (dwMajorVersion = 4) and (dwMinorVersion = 0) then
Running_OS_Name := 'Windows 95'
else if (dwMajorVersion = 4) and (dwMinorVersion = 10) then
Running_OS_Name := 'Windows 98'
else if (dwMajorVersion = 4) and (dwMinorVersion = 90) then
Running_OS_Name := 'Windows Me'
else
Running_OS_Name := UnknownWin95;
VER_PLATFORM_WIN32_NT:
if (dwMajorVersion = 5) then
Running_OS_Name := 'Windows 2000'
else
Running_OS_Name := 'Windows NT'
else
Running_OS_Name := UnknownPlatform
end;
Running_OS_Name := Running_OS_Name + ' ' +
Version (dwMajorVersion, dwMinorVersion) + '/' + vb;
if szCsdVersion [0] <> #0 then
Running_OS_Name := Running_OS_Name + ' ' + StrPas (@szCsdVersion [0])
end
end;

{$ENDIF}


{$IFDEF DOSMODE}

procedure Delay (n : longint);

const
TicksPerDay = 1572480;

var
DelayQnt : longint;
DoneTime : longint;
LastTime : longint;
ThisTime : longint;
DateFlag : boolean;
nh, nl : word;

begin

if Running_OS = OS_OS2_2 then begin
{$IFDEF VER70}
nh := n shr 8 shr 8;
{$ELSE}
nh := n shr 16;
{$ENDIF}
nl := n and $FFFF;
asm
mov dx, nh;
mov ax, nl;
hlt;
db $35,$CA
end;
exit
end;

DoneTime := MemW [Seg0040:$006C]; { What time is it? }
DelayQnt := round (n / 1000 * 18.2); { How many ticks wait? }
DateFlag := (DoneTime + DelayQnt) >= TicksPerDay; { Skip midnight? }
DoneTime := (DoneTime + DelayQnt) mod TicksPerDay; { When we'll finish? }

LastTime := MemW [Seg0040:$006C];

while (DateFlag or (LastTime < DoneTime)) do begin

{ probably fixed damned midnight freeze }

ThisTime := MemW [Seg0040:$006C];
if ThisTime < LastTime then { A new day! }
DateFlag := false;
LastTime := ThisTime;

{ Release timeslice }

case Running_OS of

OS_TOPVIEW, OS_DESQVIEW:
begin
r.AX := $1000;
Intr ($15, r)
end;

OS_DOUBLEDOS:
begin
r.AH := $EE;
if DelayQnt > 767 then
r.AL := $FF
else
r.AL := DelayQnt div 3;
dec (DelayQnt, r.AL * 3);
Intr ($21, r)
end

else
begin
r.AX := $1680;
Intr ($2F, r)
end;
end
end

end;



BEGIN

r.AX := $3000;
MsDos (r);
dosvh := r.AL;
dosvl := r.AH;
if r.BH = $00 then
vendor := 'PC'
else if r.BH = $66 then
vendor := 'PTS'
else if r.BH = $FF then
vendor := 'MS'
else
vendor := 'OEM';

{ Check for Novell NetWare to eliminate conflict with DoubleDOS detection }

r.AX := $DC00;
Intr ($21, r);

if r.AL = 0 then begin
{ NetWare is not installed, so we can check for DoubleDOS }
r.AX := $E400;
Intr ($21, r);
if r.AL <> 0 then begin { Yes, DoubleDos }
Running_OS := OS_DOUBLEDOS;
Running_OS_Name := 'DoubleDos';
exit
end;
end;

{ Check for DesqView }

r.AX := $1022;
r.BX := $0000;
Intr ($15, r);

if r.BX <> 0 then begin { Yes, DesqView or TopView }
if r.BX <> $0A01 then begin
Running_OS := OS_TOPVIEW;
Running_OS_Name := 'TopView ' + Version (r.BL, r.BH)
end
else begin
Running_OS := OS_DESQVIEW;
r.CX := $4445; { 'DE', Serg Projzogin uses it }
r.DX := $5351; { 'SQ', Serg Projzogin uses it }
r.AX := $2B01;
Intr ($21, r);
Running_OS_Name := 'DesqView ' + Version (r.BH, r.BL)
end;
exit
end;

{ Check for OS/2 }

r.AX := $4010;
r.BX := $0000;
Intr ($2F, r);

if r.BX <> 0 then begin { Yes, OS/2 }
if r.BH >= 20 then
Running_OS := OS_OS2_2
else
Running_OS := OS_OS2_1;
Include (AccessDenied, 162);
if (r.BH <> dosvh) or (r.BL <> dosvl) then begin { DOS VMB under OS/2 }
osvh := r.BH div 10;
osvl := r.BL;
if (osvh = 2) and (osvl >= 30) and (osvl < 90) then begin
osvh := osvl div 10;
osvl := osvl mod 10
end;
Running_OS_Name := vendor + ' DOS ' + Version (dosvh, dosvl) +
' under OS/2 ' + Version (osvh, osvl);
exit
end;
dosvh := dosvh div 10;
if (dosvh = 2) and (dosvl >= 30) and (dosvl < 90) then begin
dosvh := dosvl div 10;
dosvl := dosvl mod 10
end;
Running_OS_Name := 'OS/2 ' + Version (dosvh, dosvl);
exit
end;

r.AX := $1600;
Intr ($2F, r);

if r.AL <> 0 then begin { Yes, Windows }
Running_OS := OS_WINDOWS;
if r.AX = $0004 then
Running_OS_Name := 'Windows 95'
else if r.AX = $0A04 then
Running_OS_Name := 'Windows 98'
else if r.AX = $5A04 then
Running_OS_Name := 'Windows Me'
else
Running_OS_Name := 'Windows ' + Version (r.AL, r.AH);
exit
end;

Running_OS := OS_MSDOS;
Running_OS_Name := vendor + ' DOS ' + Version (dosvh, dosvl);

{$ENDIF}

END.

──────────────────────────────────[Cut Here]──────────────────────────────────