home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / vp21beta.zip / ARTLSRC.RAR / VPUTILS.PAS < prev    next >
Pascal/Delphi Source File  |  2000-08-15  |  14KB  |  540 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Utilities Library v2.1            █}
  4. {█      ─────────────────────────────────────────────────█}
  5. {█      Copyright (C) 1995-2000 vpascal.com              █}
  6. {█                                                       █}
  7. {▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
  8.  
  9. Unit VPUtils;
  10.  
  11. Interface
  12.  
  13. {$Delphi+,X+,T-,Use32+}
  14.  
  15. {$IFDEF WIN32}  {$DEFINE WIN32_DPMI32_Linux} {$ENDIF}
  16. {$IFDEF DPMI32} {$DEFINE WIN32_DPMI32_Linux} {$ENDIF}
  17. {$IFDEF Linux}  {$DEFINE WIN32_DPMI32_Linux} {$ENDIF}
  18.  
  19. uses
  20.   {$IFDEF OS2}    Os2Def, Os2Base, {$ENDIF}
  21.   {$IFDEF WIN32}  Windows,         {$ENDIF}
  22.   {$IFDEF DPMI32} Dpmi32,          {$ENDIF}
  23.   VPSysLow, Strings;
  24.  
  25. { --- System Information functions --- }
  26.  
  27. { Get the version of OS/2 or Windows }
  28. function OsVersion : Word;
  29. { Returns the time of day in milliseconds }
  30. function GetTimemSec : LongInt;
  31. { Get the process id of the current foreground process }
  32. function GetForegroundProcessId : Word;
  33.  
  34. { --- Disk related functions --- }
  35.  
  36. type
  37.   DriveSet   = Set of 'A'..'Z';
  38.  
  39. { Get the volume label of the specified drive letter }
  40. function GetVolumeLabel( Drive : Char ) : String;
  41. { Search for fName in Current Dir, then in the PATH }
  42. function FileExistsOnPath( FName : string; var FullName : string ) : Boolean;
  43. { Check if specified file handle is console(True) or redirected(False) }
  44. function IsFileHandleConsole( Handle : Word ) : Boolean;
  45. { Get the current boot drive letter }
  46. function GetBootDrive : Char;
  47. { Get the format of a drive letter }
  48. function GetDriveType( Ch: Char ) : TDriveType;
  49. { Get a list of all valid drive letters }
  50. procedure GetValidDrives( var Drives : DriveSet );
  51.  
  52. { --- Keyboard functions --- }
  53.  
  54. const
  55.   kbd_Insert    =
  56.     {$IFDEF OS2}   kbdstf_Insert_On   {$ENDIF}
  57.     {$IFDEF WIN32} VK_INSERT          {$ENDIF}
  58.     {$IFDEF DPMI32}1 shl 7            {$ENDIF}
  59.     {$IFDEF Linux} 1 shl 7            {$ENDIF} ;
  60.   kbd_CapsLock  =
  61.     {$IFDEF OS2}   kbdstf_CapsLock_On {$ENDIF}
  62.     {$IFDEF WIN32} CAPSLOCK_ON        {$ENDIF}
  63.     {$IFDEF DPMI32}1 shl 6            {$ENDIF}
  64.     {$IFDEF Linux} 1 shl 6            {$ENDIF} ;
  65.   kbd_NumLock   =
  66.     {$IFDEF OS2}   kbdstf_NumLock_On  {$ENDIF}
  67.     {$IFDEF WIN32} NUMLOCK_ON         {$ENDIF}
  68.     {$IFDEF DPMI32}1 shl 5            {$ENDIF}
  69.     {$IFDEF Linux} 1 shl 5            {$ENDIF} ;
  70.   kbd_Ctrl      =
  71.     {$IFDEF OS2}   kbdstf_Control     {$ENDIF}
  72.     {$IFDEF WIN32} VK_CONTROL         {$ENDIF}
  73.     {$IFDEF DPMI32}1 shl 2            {$ENDIF}
  74.     {$IFDEF Linux} 1 shl 2            {$ENDIF} ;
  75.   kbd_Alt       =
  76.     {$IFDEF OS2}   kbdstf_Alt         {$ENDIF}
  77.     {$IFDEF WIN32} VK_MENU            {$ENDIF}
  78.     {$IFDEF DPMI32}1 shl 3            {$ENDIF}
  79.     {$IFDEF Linux} 1 shl 3            {$ENDIF} ;
  80.   kbd_Shift     =
  81.     {$IFDEF OS2}   kbdstf_LeftShift or kbdstf_RightShift {$ENDIF}
  82.     {$IFDEF WIN32} VK_SHIFT           {$ENDIF}
  83.     {$IFDEF DPMI32}1 shl 0 or 1 shl 1 {$ENDIF}
  84.     {$IFDEF Linux} 1 shl 0 or 1 shl 1 {$ENDIF} ;
  85.  
  86. { Set/reset a bit in the keyboard state - works ONLY in full screen mode! }
  87. Procedure SetKeyboardState( Bit : SmallWord; _Or : Boolean );
  88. { Get the state of a keyboard status bit }
  89. Function GetKeyboardState( Bit : SmallWord ) : Boolean;
  90. { Get current codepage; 0 if the hardware codepage is used }
  91. Function GetCodePage : Word;
  92. { Check the next available character in the keyboard buffer }
  93. Function PeekKey( Var Ch : Char ) : Boolean;
  94.  
  95. { --- Screen related functions --- }
  96.  
  97. Procedure SetBorder;
  98. { Get the number of text columns, rows and colours }
  99. Procedure GetVideoModeInfo( Var Cols, Rows, Colours : Word );
  100. { Set the number of text columns and rows }
  101. Function SetVideoMode( Cols, Rows : Word ) : Boolean;
  102. { Get the state of ANSI interpretation }
  103. Function GetANSIState : Boolean;
  104. { Set the state of ANSI interpretation }
  105. Procedure SetANSI( State : Boolean );
  106. { Get the cursor size }
  107. Function GetCursorSize : Word;
  108. { Set the cursor size }
  109. procedure SetCursorSize(Startline, EndLine : Integer);
  110. { Hide the cursor }
  111. procedure HideCursor;
  112. { Show the cursor }
  113. procedure ShowCursor;
  114.  
  115. { --- String functions --- }
  116.  
  117. { Return zero-padded string representation of Number of length N }
  118. Function Int2StrZ( Number : Longint; N : Byte ) : String;
  119. { Return string representation of Number }
  120. Function Int2Str( Number : Longint ) : String;
  121. { Return hexadecimal equivalent of parameter Number as a string }
  122. Function Int2Hex( Number : Longint; N : Byte ) : String;
  123. { Return hexadecimal equivalent of Pointer }
  124. Function Ptr2Hex( p : Pointer ) : String;
  125.  
  126. { --- System functions --- }
  127.  
  128. { Start a thread with default parameters, returning thread ID }
  129. Function VPBeginThread( ThreadFunc : tThreadFunc; StackSize : Word; Parameters : Pointer ) : Longint;
  130. { Return the amount of memory allocated on the heap }
  131. function MemUsed: Longint;
  132. function MemComm: Longint;
  133.  
  134. { --- Math functions --- }
  135. Function Max( a,b : Longint ) : Longint; inline;
  136.   begin
  137.     if a > b then
  138.       Max := a
  139.     else
  140.       Max := b;
  141.   end;
  142.  
  143. Function Min( a,b : Longint ) : Longint; inline;
  144.   begin
  145.     if a < b then
  146.       Min := a
  147.     else
  148.       Min := b;
  149.   end;
  150.  
  151. Implementation
  152.  
  153. uses
  154.   Dos;
  155.  
  156. threadvar
  157.   SaveCursor : Word;     { Used for show/hide cursor }
  158.  
  159. { Get the OS Version }
  160. function OsVersion : Word;
  161. begin
  162.   Result := SysOSVersion;
  163. end;
  164.  
  165. { Returns the volume label of the specified drive }
  166. function GetVolumeLabel( Drive : Char ) : String;
  167. begin
  168.   Result := SysGetVolumeLabel(Drive);
  169. end;
  170.  
  171. { Returns the time of day in milliseconds }
  172. function GetTimemSec : LongInt;
  173. Var
  174.   Hour, Minute, Second, MSec: Longint;
  175. begin
  176.   SysGetDateTime(nil, nil, nil, nil, @Hour, @Minute, @Second, @MSec);
  177.   Result := 1000*( 60*(60*Hour + Minute) + Second) + MSec;
  178. end;
  179.  
  180. { Get the process id of the current foreground process }
  181. function GetForegroundProcessId : Word;
  182. begin
  183.   Result := SysGetForegroundProcessId;
  184. end;
  185.  
  186. { Search for fName in Current Dir, then PATH environment }
  187. function FileExistsOnPath(FName : string; var FullName : string) : Boolean;
  188. Var
  189.   FNameZ  : array [0..259] of Char;
  190.   Buffer  : Array [0..259] of Char;
  191.   Path    : String;
  192.  
  193. begin
  194.   FileExistsOnPath := False;
  195.  
  196.   Path := Dos.GetEnv('PATH')+#0;
  197.   StrPCopy( FNameZ, FName );
  198.   SysFileSearch(Buffer, FNameZ, @Path[1]);
  199.   FullName := StrPas( Buffer );
  200.   Result := Buffer[0] <> #0;
  201. end;
  202.  
  203. { Check if specified handle is console }
  204. function IsFileHandleConsole( Handle : Word ) : Boolean;
  205. begin
  206.   Result := SysFileIsDevice(handle) = 1;
  207. end;
  208.  
  209. { Get the current boot drive letter }
  210. function GetBootDrive : Char;
  211. begin
  212.   Result := SysGetBootDrive;
  213. end;
  214.  
  215. { Get the format of a drive letter }
  216. function GetDriveType( Ch: Char ) : TDriveType;
  217. begin
  218.   Result := SysGetDriveType(Ch);
  219. end;
  220.  
  221. { Get a list of all valid drive letters }
  222. procedure GetValidDrives( var Drives : DriveSet );
  223. var
  224.   DrivesWord : Longint absolute Drives;
  225. begin
  226.   DrivesWord := SysGetValidDrives shl 1;
  227. end;
  228.  
  229. { --- Keyboard functions --- }
  230.  
  231. { Set/reset a bit in the keyboard state - ONLY in NOVIO programs! }
  232. Procedure SetKeyboardState( Bit : SmallWord; _Or : Boolean );
  233. {$IFDEF OS2}
  234. Var
  235.   StatData  : ^KbdInfo;
  236.   LStatData : Array[1..2] of KbdInfo;
  237.   rc : Longint;
  238.  
  239. begin
  240.   StatData := Fix_64k(@LStatData, SizeOf(StatData^));
  241.  
  242.   StatData^.cb := Sizeof( StatData^ );
  243.   KbdGetStatus( StatData^, 0 );
  244.   StatData^.fsMask  := StatData^.fsMask OR keyboard_modify_State;
  245.   If _Or then
  246.     StatData^.fsState := StatData^.fsState OR Bit
  247.   else
  248.     StatData^.fsState := StatData^.fsState AND NOT Bit;
  249.   rc := KbdSetStatus( StatData^, 0 );
  250. {$ENDIF}
  251. {$IFDEF WIN32}
  252. var
  253.   State: TKeyboardState;
  254. begin
  255.   Windows.GetKeyboardState(State);
  256.   if _Or then
  257.     State[Bit] := 1
  258.   else
  259.     State[Bit] := 0;
  260.   Windows.SetKeyboardState(State);
  261. {$ENDIF}
  262. {$IFDEF DPMI32}
  263. var
  264.   Status: Byte;
  265. begin
  266.   Status := Mem[seg0040+$0017];
  267.   if _Or then
  268.     Status := Status or Bit
  269.   else
  270.     Status := Status and (not Bit);
  271.   mem[seg0040+$0017] := Status;
  272. {$ENDIF}
  273. {$IFDEF Linux}
  274. begin
  275.   // not implemented
  276. {$ENDIF}
  277. end;
  278.  
  279. { Get the state of a keyboard status bit }
  280. Function GetKeyboardState( Bit : SmallWord ) : Boolean;
  281. {$IFDEF OS2}
  282. Var
  283.   StatData  : ^KbdInfo;
  284.   LStatData : Array[1..2] of KbdInfo;
  285.   rc : Longint;
  286.  
  287. begin
  288.   StatData := Fix_64k(@LStatData, SizeOf(StatData^));
  289.   StatData^.cb := Sizeof( StatData^ );
  290.   rc := KbdGetStatus( StatData^, 0 );
  291.   GetKeyboardState := ( StatData^.fsState AND Bit <> 0 );
  292. {$ENDIF}
  293. {$IFDEF WIN32}
  294. var
  295.   State: TKeyboardState;
  296. begin
  297.   Windows.GetKeyboardState(State);
  298.   Result := State[Bit] <> 0;
  299. {$ENDIF}
  300. {$IFDEF DPMI32}
  301. begin
  302.   GetKeyboardState := (Mem[seg0040+$0017] and Bit) <> 0;
  303. {$ENDIF}
  304. {$IFDEF Linux}
  305. begin
  306.   // not implemented
  307.   GetKeyboardState := false;
  308. {$ENDIF}
  309. end;
  310.  
  311. { Returns current codepage; 0 if hardware codepage }
  312. Function GetCodePage : Word;
  313. begin
  314.   Result := SysGetCodePage;
  315. end;
  316.  
  317. { Check the next available character in the keyboard buffer }
  318. Function PeekKey( Var Ch : Char ) : Boolean;
  319. begin
  320.   Result := SysPeekKey(Ch);
  321. end;
  322.  
  323. { --- Screen functions --- }
  324.  
  325. Procedure SetBorder;
  326. {$IFDEF WIN32_DPMI32_Linux}
  327. begin
  328.   // Not implemented
  329. {$ENDIF}
  330. {$IFDEF OS2}
  331. Var
  332.   vm  : ^VioModeInfo;
  333.   Lvm : Array[1..2] of VioModeInfo;
  334. begin
  335.   vm := Fix_64k(@Lvm, SizeOf(vm^));
  336.   vm^.cb := Sizeof( vm^ );
  337.   vm^.fbType := 1;
  338.   vm^.Color := 1;
  339.   VioSetMode( vm^, 0 );
  340. {$ENDIF}
  341. end;
  342.  
  343. Procedure GetVideoModeInfo( Var Cols, Rows, Colours : Word );
  344. begin
  345.   SysGetVideoModeInfo(Cols, Rows, Colours);
  346. end;
  347.  
  348. Function SetVideoMode( Cols, Rows : Word ) : Boolean;
  349. begin
  350.   Result := SysSetVideoMode(Cols, Rows);
  351. end;
  352.  
  353. { Get the state of ANSI interpretation }
  354. Function GetANSIState : Boolean;
  355. {$IFDEF OS2}
  356. Var
  357.   w : SmallWord;
  358.  
  359. begin
  360.   If VioGetANSI( w, 0 ) = 0 then
  361.     GetANSIState := ( w = 1 )
  362.   else
  363.     GetANSIState := False;
  364. {$ENDIF}
  365. {$IFDEF WIN32}
  366. begin
  367.   Result := False;
  368. {$ENDIF}
  369. {$IFDEF Linux}
  370. begin
  371.   Result := true;
  372. {$ENDIF}
  373. {$IFDEF DPMI32}
  374. {$FRAME-} {&Uses ebx,esi,edi}
  375. asm
  376.        // Detect ansi.sys
  377.        mov     ax,$1a00
  378.        int     $2f
  379.        cmp     al,$ff
  380.        sete    al
  381. {$ENDIF}
  382. end;
  383.  
  384. { Set the state of ANSI interpretation }
  385. Procedure SetANSI( State : Boolean );
  386. {$IFDEF OS2}
  387. Var
  388.   w : SmallWord;
  389.  
  390. begin
  391.   If State then
  392.     w := 1
  393.   else
  394.     w := 0;
  395.   VioSetANSI( w, 0 );
  396. {$ENDIF}
  397. {$IFDEF WIN32_DPMI32_Linux}
  398. begin
  399.   // Not implemented
  400. {$ENDIF}
  401. end;
  402.  
  403. { Get the cursor size }
  404. Function GetCursorSize : Word;
  405. Var
  406.   cStart, cEnd: Longint;
  407.   cVisible: Boolean;
  408. begin
  409.   SysTVGetCurType(cStart, cEnd, cVisible);
  410.   Result := cStart shl 8 + cEnd;
  411. end;
  412.  
  413. { Set the cursor size }
  414. procedure SetCursorSize(Startline, EndLine : Integer);
  415. begin
  416.   SysTVSetCurType(StartLine, EndLine, (abs(StartLine) <= abs(EndLine)) or ((StartLine and $20)=0));
  417. end;
  418.  
  419. { Hide the cursor }
  420. procedure HideCursor;
  421. var
  422.   cStart, cEnd: Integer;
  423.   cVisible: Boolean;
  424. begin
  425.   SysTVGetCurType(cStart, cEnd, cVisible);
  426.   if cVisible then
  427.     SaveCursor := cStart shl 8 + cEnd;
  428.   SetCursorSize($20, 0);
  429. end;
  430.  
  431. { Show the cursor }
  432. procedure ShowCursor;
  433. var
  434.   cStart, cEnd: Integer;
  435.   cVisible: Boolean;
  436. begin
  437.   SysTVGetCurType(cStart, cEnd, cVisible);
  438.   if not cVisible then
  439.     SetCursorSize(SaveCursor shr 8, SaveCursor and $FF);
  440. end;
  441.  
  442. { Return zero-padded string representation of Number of length N }
  443. Function Int2StrZ( Number : Longint; N : Byte ) : String;
  444. Var
  445.   s : String;
  446.   i : Integer;
  447.  
  448. begin
  449.   if N = 0 then
  450.     Str( Number, s )
  451.   else
  452.     begin
  453.       Str( Number:N, s );
  454.       i := 1;
  455.       While ( s[i] = ' ' ) and ( i <= length( s ) ) do
  456.         begin
  457.           s[i] := '0';
  458.           inc( i );
  459.         end;
  460.     end;
  461.   Int2StrZ := s;
  462. end;
  463.  
  464. { Return string representation of Number }
  465. Function Int2Str( Number : Longint ) : String;
  466. Var
  467.   s : String;
  468. begin
  469.   Str( Number, s );
  470.   Int2Str := s;
  471. end;
  472.  
  473. { Return hexadecimal equivalent of parameter Number as a string }
  474. Function Int2Hex( Number : Longint; N : Byte ) : String;
  475. Const
  476.   HexDigit : Array[0..$f] of char = '0123456789ABCDEF';
  477. Var
  478.   s : String;
  479.   i : Integer;
  480.  
  481. begin
  482.   SetLength(s, N);
  483.   For i := N downto 1 do
  484.     begin
  485.       s[i] := HexDigit[Number and $F];
  486.       Number := Number shr 4;
  487.     end;
  488.   Int2Hex := s;
  489. end;
  490.  
  491. { Return hexadecimal equivalent of Pointer }
  492. Function Ptr2Hex( p : Pointer ) : String;
  493. begin
  494.   Ptr2Hex := Int2Hex( Word(p), 8 );
  495. end;
  496.  
  497. { --- System functions --- }
  498.  
  499. { Start a thread with default parameters, returning thread ID }
  500. Function VPBeginThread( ThreadFunc : tThreadFunc; StackSize : Word; Parameters : Pointer ) : Longint;
  501. begin
  502.   System.BeginThread( nil,             // Security attributes
  503.                       StackSize,       // Stack Size in bytes
  504.                       ThreadFunc,      // Thread routine
  505.                       Parameters,      // Parameter pointer
  506.                       0,               // Create_Ready
  507.                       Result );        // Function result
  508. end;
  509.  
  510. { Return the amount of memory allocated on the heap. Complements MemAvail }
  511. type
  512.   TBlockRec = record           // Heap free sub-block record
  513.     Next:      Pointer;        // Pointer to the next free sub-block
  514.     Size:      Longint;        // Size of the sub-block
  515.   end;
  516.  
  517.   PHeapRec = ^THeapRec;
  518.   THeapRec = record            // Heap Block record
  519.     Signature: Longint;        // Signature = 'VICM'
  520.     FreeList:  TBlockRec;      // Free sub-block list head
  521.     MemFree:   Longint;        // Number of free bytes in the Heap Block
  522.     TotalSize: Longint;        // Total size of the Heap Block
  523.     NextHeap:  Pointer;        // Pointer to the next Heap Block
  524.     HeapOrg:   TBlockRec;      // Heap memory starts here, marks header end
  525.   end;
  526.  
  527. function MemUsed: Longint;
  528. begin
  529.   Result := GetHeapStatus.TotalAllocated;
  530. end;
  531.  
  532. function MemComm: Longint;
  533. begin
  534.   Result := GetHeapStatus.TotalCommitted;
  535. end;
  536.  
  537. end.
  538.  
  539.  
  540.