home *** CD-ROM | disk | FTP | other *** search
/ Der Mediaplex Sampler - Die 6 von Plex / 6_v_plex.zip / 6_v_plex / DISK5 / DOS_42 / SSR100.ZIP / SSR.PAS < prev   
Pascal/Delphi Source File  |  1994-01-30  |  12KB  |  395 lines
  1. program Simple_System_Reporter ;
  2. uses crt, dos ;
  3. const
  4.    line_vt = '│' ;
  5. var
  6.    dsks, pars, sers, gmss : string ;
  7.  
  8.    f_f : text ;
  9.    sdspace, sd_free, sd_used : string ;
  10.    dspace, d_free, d_used : longint ;
  11.    p_space, p_free, p_used : real ;
  12.  
  13.    {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
  14.  
  15. function comma ( i : longint ) : string;
  16.   var w : string[14];
  17.       c : shortint;
  18.   begin
  19.      str ( i, w );
  20.  
  21.      c := (length ( w ) - 3);
  22.      while c > 0 do begin
  23.         insert ( ',', w, c + 1 );
  24.         c := c - 3
  25.      end;
  26.  
  27.      comma := w;
  28.   end;
  29.  
  30. function leadingzero ( w : word ) : string ;
  31.   var
  32.     s : string ;
  33.   begin
  34.      str ( w : 0, s ) ;
  35.      if length ( s ) = 1 then
  36.         s := '0' + s ;
  37.      leadingzero := s ;
  38.   end ;
  39.  
  40. {-----}
  41.  
  42. function DisketteDrives : Integer;
  43. { SWAG snippet, author : GAYLE DAVIS }
  44.   var
  45.     Regs : Registers;
  46.   begin
  47.      FILLChar ( Regs, SIZEOF ( Regs ), #0 );
  48.      INTR ( $11, Regs );
  49.      if Regs.AX and $0001 = 0 then
  50.         DisketteDrives := 0
  51.      else
  52.         DisketteDrives := ( (Regs.AX shl 8) shr 14) + 1;
  53.   end;
  54.  
  55. function mouse_installed : char ;
  56. { adapted from Andrew Verba's TMOUSE.pas unit }
  57. { Returns true if the mouse driver and hardware are installed.
  58.   Also resets mouse to default settings. }
  59.  
  60.   var regs : registers;
  61.  
  62.   begin
  63.      regs.ax := 0;                     { invoke mouse function 0 }
  64.      intr ( $33, regs );
  65.  
  66.      if regs.ax = 0 then
  67.         mouse_installed := 'n'
  68.      else
  69.         mouse_installed := 'Y';
  70.   end; { function mouse_installed }
  71.  
  72.  
  73. procedure check_ems ( var installed : boolean; var ver, ver2 : byte );
  74. { SWAG snippet }
  75.   var
  76.     regs  :  registers;
  77.   begin
  78.      regs.ah := $46;
  79.      intr ( $67, regs );
  80.      installed := (regs.ah = $00);
  81.      if installed then begin
  82.         ver := (Regs.AL shr 4);
  83.         ver2 := (Regs.AL and $0F);
  84.      end;
  85.   end;
  86.  
  87. procedure CallEmm ( EmmFunction : Byte; var R : Registers );
  88. { SWAG snippet }
  89.   begin
  90.      R.AH := EmmFunction;
  91.      Intr ( $67, R );
  92.      if R.AH <> 0 then
  93.         {   showhelp (9); } halt ;
  94.   end;
  95.  
  96.  
  97. procedure get_ems ( var totalems, free_ems, used_ems : word );
  98. { SWAG snippet }
  99.   var
  100.    EmmRegs : Registers;   {Registers for interrupt calls  }
  101.   begin
  102.      CallEmm ( $42, EmmRegs );
  103.      totalems := (EmmRegs.DX);
  104.      free_ems := (EmmRegs.BX);
  105.      used_ems := totalems - free_ems;
  106.   end;
  107.  
  108. function exttotal : integer ;
  109. { This code courtesy of Mark Shadley. }  { NOT currently used }
  110.   begin
  111.      asm
  112.         Mov    AL, 18h           { ; MSB of total ext in 1k blocks }
  113.         Mov    DX, 70h           { ; port                          }
  114.         Out    DX, AL            { ; write address to port 70      }
  115.         Mov    DX, 71h           { ; get data from port 71         }
  116.         in     AL, DX            { ; do it                         }
  117.         Xchg   AH, AL            { ; into MSB of AX                }
  118.  
  119.         Mov    AL, 17h           { ; LSB of total ext in 1k blocks }
  120.         Mov    DX, 70h           { ;                               }
  121.         Out    DX, AL            { ; write address to port 71      }
  122.         Mov    DX, 71h           { ; get data from port 71         }
  123.         in     AL, DX            { ; do it (into LSB of AX)        }
  124.         Mov    @result, AX       { ; save it                       }
  125.      end;
  126.   end;
  127.  
  128. procedure ioinf ( var dskstr, parstr, serstr, gmsstr : string;
  129.                   var cmem, fmem, umem : word );
  130. { some code adapted from SWAG snippets and INFOPLUS }
  131.   var
  132.     equip           : word ;
  133.     xbyte1          : byte ;
  134.     regs            : registers ;
  135.     xlong,
  136.     dosmem,
  137.     dmem            : longint ;
  138.     game_installed  : char ;
  139.  
  140.   begin
  141.      str ( disketteDrives, dskstr );
  142.      dskstr := line_vt + ' Diskettes ' + dskstr + ' ' + line_vt;
  143.  
  144.      with regs do begin
  145.         Intr ( $11, regs );
  146.         equip := AX;
  147.         Intr ( $12, regs );
  148.         DOSmem := longint ( AX ) shl 10;
  149.      end;
  150.  
  151.      xbyte1 := equip and $0E00 shr 9;
  152.      str ( xbyte1, serstr );
  153.      serstr := line_vt + ' Ser Ports ' + serstr + ' ' + line_vt;
  154.  
  155.      xbyte1 := equip and $C000 shr 14;
  156.      str ( xbyte1, parstr );
  157.      parstr := line_vt + ' Par Ports ' + parstr + ' ' + line_vt;
  158.  
  159.      if (equip and $1000) <> $1000 then
  160.         game_installed := 'n'
  161.      else
  162.         game_installed := 'Y';
  163.  
  164.      gmsstr := line_vt + ' G=' + game_installed + ' Mouse=' + mouse_installed + ' ' + line_vt;
  165.  
  166.      dmem := DOSmem div 1024;
  167.      xlong := (DOSmem - ( longint ( PrefixSeg ) shl 4)) div 1024 ;
  168.      cmem := dmem ;
  169.      fmem := xlong ;
  170.      umem := (dmem - xlong) ;
  171.  
  172.   end;
  173.  
  174. {-----}
  175.  
  176. procedure sysinf;
  177.   var
  178.       ver                     : word ;
  179.       dosmajor, dosminor,
  180.       dos_ver                 : string [9] ;
  181.       year,month,day, dow,
  182.       hour,min,sec, hund      : word ;
  183.       xday,
  184.       systemdate, systemtime  : string ;
  185.       disks                   : byte ;
  186.       ems_exists              : boolean ;
  187.       emsh, emsl              : byte ;
  188.       memc, memf, memu,
  189.       totalems, free_ems, used_ems : word ;
  190.   begin
  191.      ver := dosversion ;
  192.      str ( lo ( ver ) , dosmajor );
  193.      str ( hi ( ver ) , dosminor );
  194.      if dosminor = '' then dosminor := '0';
  195.      if length ( dosminor ) = 1 then dosminor := dosminor + '0';
  196.      dos_ver := ('DOS ' + dosmajor + '.' + dosminor);
  197.      getdate ( year, month, day, dow ) ;
  198.      systemdate := (leadingzero ( year mod 100 )) + '-' +
  199.         leadingzero ( month ) + '-' +
  200.         leadingzero ( day ) ;
  201.      case dow of
  202.         0 : xday := 'Sun';
  203.         1 : xday := 'Mon';
  204.         2 : xday := 'Tue';
  205.         3 : xday := 'Wed';
  206.         4 : xday := 'Thu';
  207.         5 : xday := 'Fri';
  208.         6 : xday := 'Sat';
  209.      end;
  210.      xday := ' ' + xday ;
  211.      gettime ( hour, min, sec, hund ) ;
  212.      systemtime := leadingzero ( hour ) + ':' +
  213.         leadingzero ( min ) + ':' +
  214.         leadingzero ( sec ) ;
  215.  
  216.      ioinf ( dsks, pars, sers, gmss, memc, memf, memu );
  217.  
  218.      check_ems ( ems_exists, emsh, emsl );
  219.      if ems_exists then
  220.         get_ems ( totalems, free_ems, used_ems )
  221.      else begin
  222.         EMSh := 0;
  223.         EMSl := 0;
  224.         totalems := 0 ;
  225.         free_ems := 0 ;
  226.         used_ems := 0 ;
  227.      end;
  228.      totalems := totalems * 16 ;
  229.      free_ems := free_ems * 16 ;
  230.      used_ems := used_ems * 16 ;
  231.  
  232.      writeln ( f_f, line_vt, 'Vers' : 9, 'Total' : 7, 'Used' : 7, 'Free ' : 8, dsks,
  233.                     ' SSR Simple System Report 1.00 ', line_vt );
  234.      writeln ( f_f, line_vt, dos_ver : 9, memc : 6, 'k', memu : 6, 'k', memf : 6, 'k ', sers,
  235.                     ' Copyright (c) 1994 Reign Ware ', line_vt );
  236.      writeln ( f_f, line_vt, ' EMS ', emsh : 1, '.', emsl : 1, ' ',
  237.               totalems : 6, 'k', used_ems : 6, 'k', free_ems : 6, 'k ',
  238.                        pars, ' (David Daniel Anderson) Free! ', line_vt );
  239.      writeln ( f_f, line_vt, ' DOS+EMS ',
  240.         memc + totalems : 6, 'k', memu + used_ems : 6, 'k', memf + free_ems : 6, 'k ',
  241.                  gmss, ' Date ', systemdate, xday,
  242.                  ' at ', systemtime, ' ', line_vt );
  243.  
  244.   end;
  245.  
  246. function makebar ( numb : byte ) : string ;
  247.   var cntr : byte ;
  248.       mbar : string ;
  249.       full : boolean ;
  250.   begin
  251.      mbar := '';
  252.      if numb > 0 then mbar := '▄' ;
  253.  
  254.      full := ( numb > 97 );
  255.  
  256.      numb := numb div 4 ;
  257.  
  258.      for cntr := 2 to numb do
  259.         mbar := mbar + '▄' ;
  260.      while length ( mbar ) < 25 do
  261.         mbar := mbar + '─' ;
  262.      if full then mbar[25] := '▄' ;
  263.      makebar := mbar ;
  264.   end;
  265.  
  266. procedure writedriveinfo ( cdrive : byte ) ;
  267.   var
  268.        ds, du, df : longint ;
  269.        sds, sdu, sdf : string ;
  270.        pspace, pfree, pused : real ;
  271.        barl : byte ;
  272.        dots : string [25];
  273.   begin
  274.      ds := disksize ( cdrive );
  275.      df := diskfree ( cdrive );
  276.      du := ds - df;
  277.  
  278.      dspace := dspace + ds; d_free := d_free + df; d_used := d_used + du;
  279.  
  280.      pfree := df; pused := du;
  281.  
  282.      pspace := ( pfree + pused  );
  283.      pfree := ( pfree / pspace ) * 100 ;
  284.      pused := ( pused / pspace ) * 100 ;
  285.  
  286.      ds := ds div 1024; df := df div 1024; du := du div 1024;
  287.  
  288.      sds := comma ( ds ); sdf := comma ( df ); sdu := comma ( du );
  289.  
  290.      barl := round ( pused );
  291.      dots := makebar ( barl ) ;
  292.  
  293.      writeln ( f_f, line_vt, '  ', chr ( cdrive + 64 ) , ':',
  294.         sds : 10, sdu : 10, sdf : 10,
  295.                  pused : 6 : 1, '%', pfree : 6 : 1, '%  ', dots, '  │' );
  296.   end;
  297.  
  298. {=============================================================================}
  299.  
  300. function IsDriveValid ( cDrive : Char; var bLocal, bSUBST : Boolean ): Boolean;
  301. { ** SWAG snippet
  302.  
  303.   Parameters: cDrive is the drive letter, 'A' to 'Z', that's about
  304.   to be checked. if not in this range, the Function will return False.
  305.  
  306.   Returns: Function returns True if the given drive is valid, else
  307.   False (!). bLocal is set if drive is local, bSUBST if drive is
  308.   substituted. if Function returns False, the Booleans are undefined.
  309. }
  310.   var
  311.     rCPU: Dos.Registers;
  312.   begin
  313.      { --- Call Dos and process returns --- }
  314.      if not (UpCase ( cDrive ) in ['A'..'Z']) then
  315.      { --- letter OK?--- }
  316.         IsDriveValid := False
  317.      else begin
  318.         { --- Valid letter, set up For the Dos-call --- }
  319.         rCPU.bx := ord ( UpCase ( cDrive ) ) - ord ( 'A' ) + 1;
  320.         rCPU.ax := $4409;
  321.         { --- Call the Dos IOCTL (InOutConTroL)-Functions --- }
  322.         Intr ( $21, rCPU );
  323.         if (rCPU.ax and FCarry) = FCarry then
  324.            IsDriveValid := False
  325.         else begin
  326.            { --- drive is valid, check status --- }
  327.            IsDriveValid := True;
  328.            bLocal := ((rCPU.dx and $1000) = $0000);
  329.            if bLocal then
  330.               bSUBST := ((rCPU.dx and $8000) = $8000)
  331.            else
  332.               bSUBST := False;
  333.         end;
  334.      end;
  335.   end; { IsDriveValid }
  336. {=============================================================================}
  337.  
  338. const
  339. line1 = '┌───────────────────────────────┬─────────────┬───────────────────────────────┐';
  340. line2 = '├───────────────────────────────┴─────────────┴───────────────────────────────┤';
  341. line3 = '│ Drv   Total-k    Used-k    Free-k  Used%  Free%  0─────Utilization─────100  │';
  342. line4 = '│ ··· ········· ········· ········· ······ ······  ·························  │';
  343. line5 = '└─────────────────────────────────────────────────────────────────────────────┘';
  344.  
  345. var
  346.    cCurChar : Char ;          { loop counter, drive }
  347.    bLocal,
  348.    bSUBST   : Boolean ;       { drive local/remote?; SUBSTed or not? }
  349.    dashes : string [25];
  350.  
  351. begin
  352.    assign ( f_f , '' );
  353.    rewrite ( f_f );
  354.    writeln ( f_f, line1 );
  355.    sysinf;
  356.    writeln ( f_f, line2 );
  357.    writeln ( f_f, line3 );
  358.  
  359.    dspace := 0 ;
  360.    d_used := 0 ;
  361.    d_free := 0 ;
  362.  
  363.    for cCurChar := 'C' to 'Z' do
  364.       if IsDriveValid ( cCurChar, bLocal, bSUBST ) then
  365.          if blocal and (not bSUBST) then
  366.             WriteDriveInfo ( ord ( cCurChar ) - 64 );
  367.  
  368.    dspace := dspace div 1024;
  369.    d_free := d_free div 1024;
  370.    d_used := d_used div 1024;
  371.  
  372.    sdspace := comma ( dspace );
  373.    sd_free := comma ( d_free );
  374.    sd_used := comma ( d_used );
  375.  
  376.    writeln ( f_f, line4 );
  377.  
  378.    p_free := d_free;
  379.    p_used := d_used;
  380.  
  381.    p_space := ( p_free + p_used  );
  382.    p_free  := ( p_free / p_space ) * 100 ;
  383.    p_used  := ( p_used / p_space ) * 100 ;
  384.  
  385.    dashes := makebar ( round ( p_used ) );
  386.  
  387.    writeln ( f_f, line_vt, ' ALL',
  388.       sdspace : 10, sd_used : 10, sd_free : 10,
  389.       p_used : 6 : 1, '%', p_free : 6 : 1, '%  ',
  390.       dashes, '  │' );
  391.  
  392.    writeln ( f_f, line5 );
  393.    close ( f_f );
  394. end.
  395.