CD Shareware Masterblend/cdsharewaremasterblend.iso/utils/infoplus/infoplus.pas

Pascal/Delphi Source File | 1990-12-08 | 14KB | 702 lines

(*
**  INFOPLUS.PAS
**
**  Version 1.41 by Andrew Rossmann 12/8/90
*)

(*$A-,B-,D-,L-,F-,I-,N-,O-,R-,S-,V-*)
(*$M 24576, 0, 0*)
program INFOPLUS;

uses
  crt, dos, graph, externs, scrprt;

const
  qversion = 'Version 1.41';
  qdate = 'December 8, 1990';
  vernum = '1.41';
  BIOSdseg = $0040;
  pgmax = 18;
  pchar = [' '..'~'];
  secsiz = 1024;
  tick1 = 1193180;
  pgnames: array [0..18] of string[32] = (
             'Table of Contents',
             'Machine & ROM Identification',
             'CPU Identification',
             'RAM Identification',
             'Memory Block Listing',
             'Video Identification',
             'Video Information',
             'Keyboard & Mouse Information',
             'Parallel/Serial Port Information',
             'DOS Information',
         {10}'Multiplex Programs',
             'Environment Variables',
             'Device Drivers',
             'DOS Drive Information',
             'BIOS Drive Information',
             'Partition Table Listing',
             'Boot info & DOS drive parameters',
             'CMOS information',
             'Thanks');
type
  char2 = string[2];

var
  attrsave : byte;
  country : array[0..33] of byte;
  currdrv : byte;
  devofs : word;
  devseg : word;
  dirsep : set of char;
  DOScofs : word;
  DOScseg : word;
  DOSmem : longint;
  equip : word;
  graphdriver : integer;
  i : word;
  intvec : array[$00..$FF] of pointer;
  lastdrv : byte;
  osmajor : byte;
  osminor : byte;
  pg : 0..pgmax;
  regs : registers;
  switchar : char;
  tlength : byte;
  twidth : byte;
  vidpg : byte;
  x1 : byte;
  x2 : byte;
  xbool1 : boolean;
  xbool2 : boolean;
  xchar1 : char;
  xchar2 : char;
  xword : word;
  gotcountry: boolean;
  c2: char2;
  quiet, endit: boolean;
  ccode: word;
  vidmode: word;
  decimal: char;

function getkey2: char2;
  var
    c: char;
    c2: char2;

  begin
  c:=ReadKey;
  if c = #0 then
    getkey2:=c + ReadKey
  else
    getkey2:=c;
  end; {getkey2}

{^Make sure number entered, not any letters}
function getnum: word;
  var
    inpchar: char;
    number_string: string[2];
    temp, position, code: word;
    row, col: byte;
    finish: boolean;

  begin
  row:=WhereY;
  col:=WhereX;
  Write(' ':3);
  GotoXY(col, row);
  temp:=99;
  finish:=false;
  position:=0;
  number_string:='';
  TextColor(LightGray);
  repeat
    inpchar:=ReadKey;
    case inpchar of
      '0'..'9':if position < 2 then
        begin
        Inc(position);
        Inc(number_string[0]);
        number_string[position]:=inpchar;
        Write(inpchar)
        end;
      #8: if position > 0 then
        begin
        Dec(position);
        Dec(number_string[0]);
        Write(^H' '^H)
        end;
      #27: if number_string = '' then
          finish:=true
        else
          begin
          number_string:='';
          GotoXY(col, row);
          ClrEol;
          position:=0
          end;
      #13: finish:=true
    end {case}
  until finish;
  if number_string <> '' then
    Val(number_string, temp, code);
  getnum:=temp
  end; {getnum}

procedure caption1(a: string);
  begin
  textcolor(LightGray);
  write(a);
  textcolor(LightCyan)
  end; {caption1}

procedure caption2(a: string);
  const
    capterm = ': ';

  var
    i: byte;
    xbool: boolean;

  begin
  i:=length(a);
  while (i > 0) and (a[i] = ' ') do
    dec(i);
  insert(capterm, a, i + 1);
  caption1(a)
  end; {caption2}

function nocarry : boolean;
  begin
  nocarry:=regs.flags and fcarry = $0000
  end; {nocarry}

function hex(a : word; b : byte) : string;
  const
    digit : array[$0..$F] of char = '0123456789ABCDEF';

  var
    i : byte;
    xstring : string;

  begin
  xstring:='';
  for i:=1 to b do
    begin
    insert(digit[a and $000F], xstring, 1);
    a:=a shr 4
    end;
  hex:=xstring
  end; {hex}

procedure unknown(a: string; b: word; c: byte);
  begin
  writeln('(unknown', ' ', a, ' ', hex(b, c), ')')
  end; {unknown}

procedure caption3(a : string);
  begin
  caption2('  ' + a)
  end; {caption3}

procedure yesorno(a : boolean);
  begin
  if a then
    writeln('yes')
  else
    writeln('no')
  end; {yesorno}

procedure yesorno2(a: boolean);
  begin
  if a then
    Write('yes')
  else
    Write('no')
  end; {yesorno2}

procedure dontknow;
  begin
  writeln('(unknown)')
  end; {dontknow}

procedure dontknow2;
  begin
  Write('(unknown)')
  end; {dontknow2}

procedure segofs(a, b : word);
  begin
  write(hex(a, 4), ':', hex(b, 4))
  end; {segofs}

function showchar(a : char) : char;
  begin
  if a in pchar then
    showchar:=a
  else
    showchar:='.'
  end; {showchar}

function power2(y: word): longint;
  begin
  power2:=Trunc(exp((y * 1.0) * ln(2.0)))
  end;

procedure pause1;
  var
    xbyte : byte;
    xchar : char2;
    savex, savey: byte;

  begin
  xbyte:=textattr;
  endit:=false;
  textcolor(Cyan);
  savex:=WhereX;
  savey:=WhereY;
  Write('( for more)');
  xchar:=getkey2;
  if xchar <> #0#80 then
    begin
    endit:=true;
    c2:=xchar
    end;
  textattr:=xbyte;
  GotoXY(savex, savey);
  Write('            ')
  end; {pause1}

procedure pause2;
  var
    xbyte : byte;

  begin
  if wherey + hi(windmin) > hi(windmax) then
    begin
    xbyte:=TextAttr;
    TextColor(Cyan);
    pause1;
    if not endit then
      begin
      Clrscr;
      Writeln('(continued)');
      end;
    textattr:=xbyte
    end
  end; {pause2}

procedure pause3(extra: byte);
  var
    xbyte: byte;
  begin
  if WhereY + Hi(WindMin) + extra > Hi(WindMax) then
    begin
    xbyte:=TextAttr;
    TextColor(Cyan);
    pause1;
    if not endit then
      begin
      ClrScr;
      Writeln('(continued)');
      end;
    TextAttr:=xbyte
    end
  end; {pause3}

function bin4(a : byte) : string;
  const
    digit : array[0..1] of char = '01';

  var
    xstring : string;
    i : byte;

  begin
  xstring:='';
  for i:=3 downto 0 do
    begin
    insert(digit[a mod 2], xstring, 1);
    a:=a shr 1
    end;
  bin4:=xstring
  end; {bin4}

procedure offoron(a : string; b : boolean);
  begin
  caption3(a);
  if b then
    writeln('on')
  else
    writeln('off')
  end; {offoron}

procedure zeropad(a : word);
  begin
  if a < 10 then
    write('0');
  write(a)
  end; {zeropad}

procedure showvers;
  begin
  if osmajor > 0 then
    begin
    Write(osmajor, decimal);
    zeropad(osminor);
    writeln
    end
  else
    writeln('1', decimal, 'x')
  end; {showvers}

function cbw(a, b : byte) : word;
  begin
  cbw:=word(b) shl 8 + a
  end; {cbw}

function bin16(a : word) : string;
  function bin8(a : byte) : string;
    begin
    bin8:=bin4(a shr 4) + '_' + bin4(a and $0F)
    end; {bin8}

  begin {bin16}
  bin16:=bin8(hi(a)) + '_' + bin8(lo(a))
  end; {bin16}

procedure drvname(a : byte);
  begin
  write(chr(ord('A') + a), ': ')
  end; {drvname}

procedure media(a, b : byte);
  procedure diskette(a, b, c : byte);
    begin
    writeln('floppy ', a, ' side, ', b, ' sctr, ', c, ' trk')
    end; {diskette}

  begin {media}
  caption3('Media');
  case a of
    $FF : diskette(2, 8, 40);
    $FE : diskette(1, 8, 40);
    $FD : diskette(2, 9, 40);
    $FC : diskette(1, 9, 40);
    $F9 : if b = 1 then
      diskette(2, 15, 80)
    else
      diskette(2, 9, 80);
    $F8 : writeln('fixed disk');
    $F0 : diskette(2, 18, 80)
    else
      unknown('media', a, 2)
  end
  end; {media}

procedure pagenameclr;
  var
    xbyte: byte;

  begin
  xbyte:=TextAttr;
  Window(x1, tlength, x2 - 1, tlength);
  TextColor((TextAttr and $70) shr 4);
  ClrScr;
  TextAttr:=xbyte;
  Window(1, 1, twidth, tlength)
  end; {pagenameclr}

procedure Intr(intno: byte; var regs: registers);
  begin
  AltIntr(intno, regs)
  end;

procedure MsDos(var regs: registers);
  begin
  AltMsDos(regs)
  end;

procedure init;
  var
    xint : integer;

  procedure rjustif