home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PCS4.ZIP / PCS.PAS
Encoding:
Pascal/Delphi Source File  |  1987-11-28  |  16.0 KB  |  570 lines
  1. {$B-} {- = short circuit boolean evaluation: on }
  2. {$D-} {+ = debug & lineinfo: on }
  3. {$F-} {- = force far calls: off }
  4. {$I-} {+ = I/O error checking: on }
  5. {$L+} {+ = link buffer: on }
  6. {$N-} {- = 8087 code: off }
  7. {$R-} {- = numeric range checking: off }
  8. {$S-} {+ = stack overflow checking: on }
  9. {$T-} {- = map file generation: off }
  10. {$V-} {+ = var-string checking: on }
  11. {$M 16384,0,0} { memory in bytes: stacksize,heapmin,heapmax }
  12.  
  13. {=====================================================================
  14.  PC STATUS -- Version 4.0
  15.  Author:      John D. Falconer
  16.  Modified by: Michael J. Borowiec [72067,3025]            11.27.87
  17.  
  18.  This modified version of "PCS.PAS" differs from the original:
  19.  
  20.  Function "UseEnv" has been added (is no longer an external codefile)
  21.    and is called differently.
  22.  
  23.  Procedure "ShowSysID" has been added for IBM  systems.
  24.  
  25.  Bug fixed in "ShowVideoInfo". (Missing "CrtMode" pointer statement)
  26.  
  27.  Function Self added to show from whence it executes...
  28.  
  29.  Extensively modified for Turbo Pascal 4.0.
  30.  
  31.  =====================================================================}
  32.  
  33. program PCS;
  34.  
  35. uses
  36.   DOS,CRT;
  37. const
  38.   DosDS        = $0040;
  39.   DosDSStr     = '0040:';
  40. type
  41.   Info         = record case word of
  42.                    1 : (b: byte);
  43.                    2 : (w: word);
  44.                    3 : (pac: packed array[0..7] of char);
  45.                  end;
  46.   AddrPtr      = ^FullAddr;
  47.   FullAddr     = record
  48.                    Offset,
  49.                    Segment : word
  50.                  end;
  51.   String4      = string[4];
  52.   String64     = string[64];
  53.   String80     = string[80];
  54. var
  55.   Regs         : registers;
  56.   CrtModeSet,
  57.   DataPtr      : ^Info;
  58.   EquipWord,
  59.   MaxDrives,
  60.   MemSize, I   : word;
  61.   CGA80        : boolean;
  62.  
  63.  
  64. {}procedure QWrite(Row,Col,Attr : byte;
  65.                    QWriteStr    : String80);
  66.   begin
  67.     gotoxy(Col,Row);
  68.     Crt.TextAttr:= Attr;
  69.     write(QWriteStr);
  70. {}end; { procedure QWrite }
  71.  
  72.  
  73. {}procedure Layout;
  74.   begin
  75.     clrscr;
  76.     QWrite(1 ,1 ,3 ,'╔═══════════════════╤═══════════════════╤═════════════════════════════════════╗');
  77.     QWrite(2 ,1 ,3 ,'║');
  78.     QWrite(2 ,3 ,14,'MEMORY:');
  79.     QWrite(2 ,21,3 ,'│');
  80.     QWrite(2 ,23,14,'EQUIPMENT:');
  81.     QWrite(2 ,41,3 ,'│');
  82.     QWrite(2 ,43,14,'VIDEO:');
  83.     QWrite(2 ,79,3 ,'║');
  84.     QWrite(3 ,1 ,3 ,'║ Planar            │ Printers          │ Initial Mode                        ║');
  85.     QWrite(4 ,1 ,3 ,'║ Total             │ Serial Ports      │ Current Mode                        ║');
  86.     QWrite(5 ,1 ,3 ,'║ Free              │ Floppy Drives     │ Attribute @ Cursor                  ║');
  87.     QWrite(6 ,1 ,3 ,'║ From              │ Game Adaptor      │ Buffer Offset, Length               ║');
  88.     QWrite(7 ,1 ,3 ,'╟───────────────────┴───────────────────┤ Video Page                          ║');
  89.     QWrite(8 ,1 ,3 ,'║');
  90.     QWrite(8 ,3 ,14,'KEYBOARD BUFFER:');
  91.     QWrite(8 ,41,3 ,'│ Cursor Mode                         ║');
  92.     QWrite(9 ,1 ,3 ,'║ Capacity           Start              │ 6845 Mode                           ║');
  93.     QWrite(10,1 ,3 ,'║ ( characters )       End              │ 6845 Pallette                       ║');
  94.     QWrite(11,1 ,3 ,'╟───────────────────┬───────────────────┼─────────────────┬───────────────────╢');
  95.     QWrite(12,1 ,3 ,'║');
  96.     QWrite(12,3 ,14,'DOS VER:');
  97.     QWrite(12,21,3 ,'│');
  98.     QWrite(12,23,14,'ROM VER:');
  99.     QWrite(12,41,3 ,'│');
  100.     QWrite(12,43,14,'^C CHECK:');
  101.     QWrite(12,59,3 ,'│');
  102.     QWrite(12,61,14,'DISK VERIFY:');
  103.     QWrite(12,79,3 ,'║');
  104.     QWrite(13,1 ,3 ,'╟───────────────────┴───────────────────┴─────────────────┴───────────────────╢');
  105.     QWrite(14,1 ,3 ,'║');
  106.     QWrite(14,3 ,14,'FREE SPACE ON DISK DRIVES:');
  107.     QWrite(14,79,3 ,'║');
  108.     QWrite(15,1 ,3 ,'║'); QWrite(15,79,3 ,'║');
  109.     QWrite(16,1 ,3 ,'║'); QWrite(16,79,3 ,'║');
  110.     QWrite(17,1 ,3 ,'╟────────────────────┬────────────────────────────────────────────────────────╢');
  111.     Qwrite(18,1 ,3 ,'║');
  112.     Qwrite(18,3 ,14,'Floppy PARAMETERS:');
  113.     Qwrite(18,22,3 ,'│');
  114.     Qwrite(18,24,14,'ENVIRONMENT SETTINGS:');
  115.     Qwrite(18,79,3 ,'║');
  116.     Qwrite(19,1 ,3 ,'║ On Time         ms │'); QWrite(19,79,3 ,'║');
  117.     Qwrite(20,1 ,3 ,'║ Off Time        s  │'); QWrite(20,79,3 ,'║');
  118.     Qwrite(21,1 ,3 ,'║ Settling        ms │'); QWrite(21,79,3 ,'║');
  119.     Qwrite(22,1 ,3 ,'║ B/S, S/T           │'); QWrite(22,79,3 ,'║');
  120.     Qwrite(23,1 ,3 ,'╚════════════════════╧════════════════════════════════════════════════════════╝');
  121. {
  122.     Qwrite(24,1 ,3 ,Self);
  123. }
  124.     QWrite(24,56,3 ,'PC STATUS - Version 4.0');
  125. {}end; { procedure Layout }
  126.  
  127.  
  128. {}function HexString(Number: Word): String4;
  129.   var
  130.     S : String4;
  131.  
  132. {--}function HexChar(Number: Word): Char;
  133.     begin
  134.       if Number < 10 then
  135.         HexChar:= char(Number + 48)        { variable typecasting }
  136.       else
  137.         HexChar:= char(Number + 55);       {     "          "     }
  138. {--}end; { function HexChar }
  139.  
  140.   begin { function HexString }
  141.     S     := '';
  142.     S     := HexChar((Number shr 1) div 2048);
  143.     Number:= (((Number shr 1) mod 2048) shl 1) + (Number and 1);
  144.     S     := S + HexChar(Number div 256);
  145.     Number:= Number mod 256;
  146.     S     := S + HexChar(Number div 16);
  147.     Number:= Number mod 16;
  148.     S     := S + HexChar(Number);
  149.     HexString:= S;
  150. {}end; { function HexString }
  151.  
  152.  
  153. {}procedure WriteHex(Row,Col : byte;
  154.                      Value   : word);
  155.   begin
  156.     gotoxy(Col,Row);
  157.     write(HexString(Value));
  158. {}end; { WriteHex }
  159.  
  160.  
  161. {}procedure ShowSysID;
  162.   var
  163.     IDByte : byte;
  164.   begin
  165.     gotoxy(34,2);
  166.     IDByte:= mem[$F000:$FFFE];
  167.     case IDByte of
  168.       $FF :write('PC':6);
  169.       $FE :write('XT':6);
  170.       $FD :write('PCjr':6);
  171.       $FC :write('AT':6)
  172.     else
  173.       write(HexString(word(IDByte)),'h')
  174.     end;
  175. {}end; { procedure ShowSysID }
  176.  
  177.  
  178. {}function Self : String64; { requires MS-DOS 3.x }
  179. {
  180. Original function (c)1986 D.M.Armstrong-Allen and
  181. Published in PC Magazine Vol 6 No 11, June 9, 1987.
  182. Modified by Michael BoRowiec for Turbo Pascal 4.x
  183. }
  184.   var
  185.     Temp      : String64;
  186.     I,EnvSeg  : word;
  187.   begin
  188.     I   := 0;
  189.     Temp:= '';
  190.     EnvSeg:= memw[prefixseg:$2C];  { have to set this up like any variable! }
  191.     while memw[EnvSeg:I] <> 0 do   { read through environment strings }
  192.       inc(I);
  193.     inc(I,4);                      { jump around 2 null bytes & word count }
  194.     while mem[EnvSeg:I] <> 0 do    { skim off path & filename }
  195.       begin
  196.         Temp:= Temp + upcase(chr(mem[EnvSeg:I]));
  197.         inc(I);
  198.       end;
  199.     Self:= Temp;
  200. {}end; { function Self }
  201.  
  202.  
  203. {}procedure ShowEquipment;
  204.   begin
  205.     DataPtr  := ptr(DosDS,$0010);          { pointer to BIOS equipment list }
  206.     EquipWord:= DataPtr^.W;
  207.     MaxDrives:= ((EquipWord shr 6) and 3) * (1 and EquipWord)
  208.                 + (1 and EquipWord);       { number of floppies }
  209.     gotoxy(38,3);
  210.     write(EquipWord shr 14:2);             { number of printers }
  211.     gotoxy(38,4);
  212.     write((EquipWord shr 9) and 7:2);      { number of serial ports }
  213.     gotoxy(38,5);
  214.     write(MaxDrives:2);                    { write number of floppies }
  215.     gotoxy(38,6);
  216.     write((EquipWord shr 12) and 1:2);     { number of game adapters }
  217.     gotoxy(13,3);
  218.     write(((EquipWord shr 2) and 3) * 16 + 16:6, 'K'); { Planar Memory }
  219. {}end; { procedure ShowEquipment }
  220.  
  221.  
  222. {}procedure ShowTotalMemory;
  223.   begin
  224.     gotoxy(13,4);
  225.     DataPtr:= ptr(DosDS,$0013);            { total memory }
  226.     MemSize:= DataPtr^.W;
  227.     write(MemSize:6,'K');
  228. {}end; { procedure ShowTotalMemory }
  229.  
  230.  
  231. {}procedure ShowMemUsage;
  232.   begin
  233.     gotoxy(16,5);
  234.     write(MemSize - (prefixseg + 16) div 64,'K');    { total free memory }
  235.     WriteHex(6,10,prefixseg);                        { starting address  }
  236.     write(':0100h');
  237. {}end; { procedure ShowMemUsage }
  238.  
  239.  
  240. {}procedure ShowKBInfo;
  241.   var
  242.     KBStart,
  243.     KBEnd  : word;
  244.   begin
  245.     DataPtr := ptr(DosDS,$0080);           { start of KB buffer area }
  246.     KBStart := DataPtr^.W;
  247.     gotoxy(30,9);
  248.     write(DosDSStr);
  249.     write(HexString(KBStart),'h');
  250.     DataPtr:= ptr(DosDS,$0082);            { end of KB buffer area }
  251.     KBEnd  := DataPtr^.W;
  252.     gotoxy(30,10);
  253.     write(DosDSStr);
  254.     write(HexString(KBEnd),'h');
  255.     gotoxy(14,9);
  256.     writeln((KBEnd - KBStart)/2 - 1:0:0);  { difference in bytes }
  257. {}end; { procedure ShowKBInfo }
  258.  
  259.  
  260. {}procedure ShowVideoInfo;
  261.  
  262. {--}procedure ShowInitialVideo(Mode : word);
  263.     begin
  264.       gotoxy(64,3);
  265.       case (mode) and 3 of
  266.         1: write('40 x 25 BW/CGA');
  267.         2: write('80 x 25 BW/CGA');
  268.         3: write('80 x 25 BW/BW');
  269.       end; { case }
  270. {--}end; { procedure ShowInitialVideo }
  271.  
  272. {--}procedure ShowCurrentVideo;
  273.     begin
  274.       DataPtr:= ptr(DosDS,$0049);
  275.       gotoxy(64,4);
  276.       case (DataPtr^.B) of
  277.         0: write('40 x 25 BW');
  278.         1: write('40 x 25 color');
  279.         2: write('80 x 25 BW');
  280.         3: write('80 x 25 color');
  281.       end; { case }
  282.       CGA80 := DataPtr^.B = 3
  283. {--}end; { ShowCurrentVideo }
  284.  
  285. {--}procedure ShowAttribute;               { at cursor }
  286.  
  287. {----}function GetAttr: byte;
  288.       begin
  289.         Regs.AX:= $0800;
  290.         Regs.BX:= $0100;
  291.         intr($10,Regs);
  292.         GetAttr:= Regs.AX shr 8
  293. {----}end; { function GetAttr }
  294.  
  295.     begin
  296.       gotoxy(72,5);
  297.       write(GetAttr:6)
  298. {--}end; { procedure ShowAttribute }
  299.  
  300.   begin
  301.     ShowInitialVideo(EquipWord shr 4);
  302.     ShowCurrentVideo;
  303.     ShowAttribute;
  304.     DataPtr:= ptr(DosDS,$004E);              { crt_start }
  305.     gotoxy(65,6);
  306.     write(DataPtr^.W:6,',');
  307.     DataPtr:= ptr(DosDS,$004C);              { crt_len }
  308.     gotoxy(72,6);
  309.     write(DataPtr^.W:6);
  310.     DataPtr:= ptr(DosDS,$0062);              { active_page }
  311.     gotoxy(72,7);
  312.     write(DataPtr^.B:6);
  313.     DataPtr:= ptr(DosDS,$0060);              { cursor_mode }
  314.     gotoxy(72,8);
  315.     write(DataPtr^.W:6);
  316.     DataPtr:= ptr(DosDS,$0049);              { crt_mode }
  317.     gotoxy(72,9);
  318.     write(DataPtr^.B:6);
  319.     DataPtr:= ptr(DosDS,$0066);              { crt_pallette }
  320.     gotoxy(72,10);
  321.     write(DataPtr^.B:6)
  322. {}end; { procedure ShowVideoInfo }
  323.  
  324.  
  325. {}procedure GetVersion(var DosVersion : String4);
  326.   begin
  327.     DosVersion:= ' .00';
  328.     Regs.AX   := $3000;
  329.     msdos(Regs);
  330.     DosVersion[1]:= chr(lo(Regs.AX) + ord('0'));
  331.     if hi(Regs.AX) >= 10 then
  332.       DosVersion[3]:= chr((hi(Regs.AX) div 10) + ord('0'));
  333.     DosVersion[4]  := chr((hi(Regs.AX) mod 10) + ord('0'));
  334. {}end; { procedure GetVersion }
  335.  
  336.  
  337. {}procedure ShowVersionInfo;
  338.   var
  339.     DosVersion : String4;
  340.  
  341.   begin
  342.     GetVersion(DosVersion);                { DOS Version }
  343.     gotoxy(16, 12);
  344.     write(DosVersion);
  345.     DataPtr:= ptr($F000, $FFF5);           { BIOS Version }
  346.     gotoxy(32, 12);
  347.     for I:= 0 to 7 do
  348.       write(DataPtr^.PAC[I]);
  349. {}end; { procedure ShowVersionInfo }
  350.  
  351.  
  352. {}procedure ShowSelf;
  353.   var
  354.     RealVersion : real;
  355.     ValCode     : word;
  356.     DosVersion  : string[4];
  357.   begin
  358.     GetVersion(DosVersion);
  359.     val(DosVersion,RealVersion,ValCode);
  360.     if (RealVersion >= 3.0) and (ValCode = 0) then
  361.       begin
  362.         gotoxy(1,24);
  363.         write(Self);
  364.       end;
  365. {}end; { procedure ShowSelf }
  366.  
  367.  
  368. {}procedure ShowCtrlC;
  369.  
  370. {--}function CtrlCCheck : boolean;
  371.     begin
  372.       Regs.AX:= $3300;
  373.       msdos(Regs);
  374.       CtrlCCheck:= (Regs.DX and $01) = 1;
  375. {--}end; { function CtrlCCheck }
  376.  
  377.   begin
  378.     gotoxy(55, 12);
  379.     if CtrlCCheck then
  380.       write('ON':3)
  381.     else
  382.       write('OFF');
  383. {}end; { procedure ShowCtrlC }
  384.  
  385.  
  386. {}procedure ShowDiskVerify;
  387.  
  388. {--}function DiskVerifyCheck : boolean;
  389.     begin
  390.       Regs.AX:= $5400;
  391.       msdos(Regs);
  392.       DiskVerifyCheck:= (Regs.AX and $01) = 1
  393. {--}end; { function DiskVerifyCheck }
  394.  
  395.   begin
  396.     gotoxy(75, 12);
  397.     if DiskVerifyCheck then
  398.       write('ON':3)
  399.     else
  400.       write('OFF');
  401. {}end; { procedure ShowDiskVerify }
  402.  
  403.  
  404. {}function UseEnv(var Name: string80; var Value: string80): boolean;
  405.   var
  406.     Env     : string;
  407.     EP0,EP1 : pointer;
  408.     EnvPos  : word;
  409.  
  410. {--}procedure SubString(Source        :string;
  411.                         DelimL,DelimR :string80;
  412.                     var Object        :string80;
  413.                     var Position      :word);
  414.  
  415.     var
  416.       SourceLen,LeftDLen,RightDLen,DelimLPos,DelimRPos : word;
  417.  
  418.     begin
  419.       SourceLen:= length(Source);
  420.       LeftDLen := length(DelimL);
  421.       RightDLen:= length(DelimR);
  422.       Object   := '';
  423.       Position := 0;
  424.       if (SourceLen < 2) or (LeftDLen = 0) or (RightDLen = 0) then
  425.         exit;
  426.       DelimLPos:= pos(DelimL,Source);
  427.       if DelimLPos = 0 then
  428.         exit;
  429.       delete(Source,1,DelimLPos + LeftDLen - 1);
  430.       SourceLen:= length(Source);
  431.       if SourceLen = 0 then
  432.         exit;
  433.       DelimRPos:= pos(DelimR,Source);
  434.       if DelimRPos > 0 then
  435.         begin
  436.           Position:= DelimLPos;
  437.           Object  := copy(Source,1,DelimRPos - 1)
  438.         end;
  439. {--}end; { procedure SubString }
  440.  
  441.   begin { function UseEnv }
  442.     EP0   := ptr(memw[prefixseg:$002C],0);
  443.     EP1   := @Env[1];
  444.     Env[0]:= chr($FF);
  445.     move(EP0^,EP1^,length(Env) - 1);
  446.     SubString(Env,Name + '=',chr(0),Value,EnvPos);
  447.     if EnvPos > 0 then
  448.       UseEnv:= true
  449.     else
  450.       UseEnv:= false;
  451. {}end; { function UseEnv }
  452.  
  453.  
  454. {}procedure ShowEnvInfo;
  455.   var
  456.     EnvName,
  457.     EnvValue,
  458.     EnvValue2 : string80;
  459.  
  460. {--}procedure ShowEnv(Row,Col : byte;
  461.                       EnvName : string80);
  462.     var
  463.       EnvLength,
  464.       Position  : byte;
  465.       TestChar  : char;
  466.     begin
  467.       gotoxy(Col,Row);
  468.       write(EnvName + ' = ':10);
  469.       if UseEnv(EnvName,EnvValue) then
  470.         begin
  471.           EnvLength:= length(EnvValue);
  472.           if (EnvName = 'PATH') and (EnvLength > 45) then
  473.             begin
  474.               Position:= EnvLength;
  475.               while (EnvValue[Position] <> ';') or (Position > 45) do
  476.                 dec(Position);
  477.               EnvValue2:= copy(EnvValue,Position + 1,EnvLength);
  478.               EnvValue[0]:= chr(Position);
  479.               write(EnvValue);
  480.               gotoxy(Col + 10,Row + 1);
  481.               write(EnvValue2);
  482.             end
  483.           else
  484.             write(EnvValue);
  485.         end
  486.       else
  487.         write('undefined');
  488. {--}end; { procedure ShowEnv }
  489.  
  490.   begin
  491.     ShowEnv(19,24,'COMSPEC');
  492.     ShowEnv(20,24,'PROMPT');
  493.     ShowEnv(21,24,'PATH');
  494. {}end; { procedure ShowEnvInfo }
  495.  
  496.  
  497. {}procedure ShowDiskParms;
  498.   const
  499.     DiskPointer = $0078;
  500.   type
  501.     DiskInfo    = record
  502.                     Misc1,       Misc2,        MotorWait,
  503.                     BytesSector, SectorsTrack, GapLength,
  504.                     DTL,         FmtGapLength, FmtFillByte,
  505.                     Settle,      MotorStart    : byte
  506.                   end;
  507.   var
  508.     DiskVector  : AddrPtr;
  509.     DiskParms   : ^DiskInfo;
  510.   begin
  511.     DiskVector:= ptr($0000,DiskPointer);
  512.     DiskParms := ptr(DiskVector^.Segment,DiskVector^.Offset);
  513.     with DiskParms^ do
  514.       begin
  515.         gotoxy(15,19);
  516.         write(125 * MotorStart:3);
  517.         gotoxy(15,20);
  518.         write(MotorWait / 18.5:3:1);
  519.         gotoxy(15,21);
  520.         write(Settle:3);
  521.         gotoxy(14,22);
  522.         write(256 * BytesSector:3,',');
  523.         gotoxy(18,22);
  524.         write(SectorsTrack:3);
  525.       end;
  526. {}end; { procedure ShowDiskParms }
  527.  
  528.  
  529. {}procedure ShowDriveSpace;
  530.   var
  531.     Drive,
  532.     ValidDrive : byte;
  533.     FreeBytes  : longint;
  534.   begin
  535.     Drive     := 0;
  536.     ValidDrive:= 0;
  537.     while (Drive < 26) and (ValidDrive < 9) do
  538.       begin
  539.         gotoxy((3 + ValidDrive mod 4 * 20),(15 + ValidDrive div 4));
  540.         inc(Drive);
  541.         FreeBytes:= diskfree(Drive);
  542.         if FreeBytes >= 0 then
  543.           begin
  544.             write(chr((Drive - 1)+ ord('A')),': ',FreeBytes);
  545.             inc(ValidDrive);
  546.           end;
  547.       end;
  548. {}end; { procedure ShowDriveSpace }
  549.  
  550. (*((((((((((((((((((((   O U T E R   B L O C K   ))))))))))))))))))))*)
  551.  
  552. BEGIN
  553.   Layout;
  554.   textcolor(green);
  555.   ShowSelf;
  556.   ShowSysID;
  557.   ShowEquipment;
  558.   ShowTotalMemory;
  559.   ShowMemUsage;
  560.   ShowKBInfo;
  561.   ShowVideoInfo;
  562.   ShowVersionInfo;
  563.   ShowCtrlC;
  564.   ShowDiskVerify;
  565.   ShowEnvInfo;
  566.   ShowDiskParms;
  567.   ShowDriveSpace;
  568.   gotoxy(1, 24);
  569. END.
  570.