The World of Computer Software/World_Of_Computer_Software-02-385-Vol-1of3.iso/d/drcpas10.zip/DOSTOOLS.PAS

Pascal/Delphi Source File | 1992-11-17 | 12KB | 504 lines

{$A+,B-,D-,F-,I+,L-,N-,O-,R-,S+,V-}
Unit DosTools;

(* by David R. Conrad, for Turbo Pascal 5.5

   This code is not copyrighted, you may use it freely.
   There are no guarantees, either expressed or implied,
   as to either merchantability or fitness for a particular
   purpose.  The author's liability is limited to the amount
   you paid for it.

   David R. Conrad, 17 Nov 92
   [e-mail]
   [e-mail]
*)

Interface

Uses Dos;

type
  (* like namestr, extstr *)
  filestr = string[12];

const
  (* for use with CrtMode, to detect monochrome *)
  mono       = 7;
  (* for use with Boot, to select boot type *)
  WarmBoot   = 0;
  ColdBoot   = 1;
  ResetBoot  = 2;
  (* for use with the printer functions *)
  PrnNotBusy = $80;
  PrnAck     = $40;
  PrnNoPaper = $20;
  PrnSelect  = $10;
  PrnIOError = $08;
  PrnTimeout = $01;
  (* for use with PrtScStat, status of last Print Screen operation *)
  PrtScOn    = $00;          (* PrtSc ready *)
  PrtScOff   = $01;          (* PrtSc busy (in progress) *)
  PrtScErr   = $FF;          (* an error occurred *)

var
  CrtMode   : Byte Absolute $0040:$0049;
  PrtScStat : Byte Absolute $0050:$0000;

(* all routines are documented in the implementation section *)

Function Ampm : String;
Function Ampmn : String;
Procedure Boot (BootType : Integer);
Procedure Call (Proc : Pointer);
Procedure CursBlock;
Procedure CursHalf;
Procedure Cursoff;
Procedure Curson;
Procedure Cursor (a,b : byte);
Function Date : String;
Function Datec : String;
Procedure DiskAlloc (    Drive : Byte;
                     var Cluster : Integer; var Free, Cap, Used : Longint);
Procedure DisableInterrupts; Inline ($FA); {CLI}
Procedure EnableInterrupts;  Inline ($FB); {STI}
Function Exist (FN : Pathstr) : Boolean;
Function Exists (FN : Pathstr) : Boolean;
Function IsDir (FN : Pathstr) : Boolean;
Function IsLabel (FN : Pathstr) : Boolean;
Function IsWritable (FN : Pathstr) : Boolean;
Function GetLabel (Drive : Char) : FileStr;
Function GetCursor : Word;
Procedure InitRegisters (var Reg : Registers);
Function PrnOnline (PrinterNumber : Byte) : Boolean;
Function PrnReady (PrinterNumber : Byte) : Boolean;
Function PrnStatus (PrinterNumber : Byte) : Byte;
Function PrnErr (Err : Byte) : String;
Function Time : String;
Function Timen : String;
Function WeekDay : String;

Implementation

Function Ampm : String;
(* time in the format '09:30:47 pm' *)
var
  h,m,s,w,ap : string;
  hour,min,sec,sec100,
  i : word;
begin
  GetTime (hour,min,sec,sec100);
  ap := 'am';
  If hour > 11 then ap := 'pm';
  If hour > 12 then
    hour := hour - 12;
  str (hour:2,h);
  str (min:2,m);
  str (sec:2,s);
  If h = ' 0' then h := '12';
  w := h + ':' + m + ':' + s + ' ' + ap;
  for i := 2 to length(w) - 3 do if w[i]=' ' then w[i]:='0';
  ampm := w;
end;

Function Ampmn : String;
(* time in the format '09:30 pm' *)
var
  h,m,w,ap : string;
  hour,min,sec,sec100,
  i : word;
begin
  GetTime (hour,min,sec,sec100);
  ap := 'am';
  If hour > 11 then ap := 'pm';
  If hour > 12 then
    hour := hour - 12;
  str (hour:2,h);
  str (min:2,m);
  If h = ' 0' then h := '12';
  w := h + ':' + m + ' ' + ap;
  for i := 2 to length(w) - 3 do if w[i]=' ' then w[i]:='0';
  ampmn := w;
end;

Procedure Boot (BootType : Integer);
(* reboot the computer, flushing caches first *)
const
  bootwarm = $1234;
  bootcold = 0;
var
  reg : registers;
  bootaddr : pointer;
  warmcold : word absolute $40:$72;
  shifts : byte absolute $40:$17;
begin
  initregisters (reg);
  bootaddr := ptr($FFFF,0);
  if (BootType < 0) or (BootType > 2) then exit;
  case boottype of
    warmboot : warmcold := bootwarm;
    coldboot : warmcold := bootcold;
  end;
  reg.ah := $0D;
  intr ($21, reg);
  shifts := (4 OR 8);                  {Ctrl-Alt}
  repeat
    reg.flags := FCarry;
    reg.ax := $4F53;                   {Translate scan codes, Del}
    intr ($15, reg);
  until (reg.flags AND FCarry) = FCarry;
  case boottype of
    warmboot  : call (bootaddr);       {One call we won't be returning from}
    coldboot  : call (bootaddr);
    resetboot : begin
                  DisableInterrupts;
                  port[$64] := $FE;    {Tell keyboard to reset processor}
                  while (true) do;     {Wait for it}
                end;
  end;
end;

var
  CallAddr : Pointer;

Procedure Call (Proc : Pointer);
(* call a procedure with no parameters *)

  Procedure CallProc; Inline ($FF/$1E/CallAddr);
                             {CALL DWORD PTR CallAddr}
begin
  CallAddr := Proc;
  CallProc;
end;

Procedure CursBlock;
(* change the cursor to a full-height block *)
var
  reg : Registers;
begin
  initregisters (reg);
  If crtmode = mono then
    reg.cx := $00C
  else
    reg.cx := $007;
  reg.bx := 0;
  reg.ax := $0100;
  intr ($10,reg);
end;

Procedure CursHalf;
(* change the cursor to a half-height block *)
var
  reg : Registers;
begin
  initregisters (reg);
  If crtmode = mono then
    reg.cx := $070C
  else
    reg.cx := $0407;
  reg.bx := 0;
  reg.ax := $0100;
  intr ($10,reg);
end;

Procedure Cursoff;
(* turn the cursor off *)
var
  reg : Registers;
begin
  initregisters (reg);
  reg.cx := $2000;
  reg.bx := 0;
  reg.ax := $0100;
  intr ($10,reg);
end;

Procedure Curson;
(* set the cursor to its normal (underline) form *)
var
  reg : Registers;
begin
  initregisters (reg);
  If crtmode = mono then
    reg.cx := $B0C
  else
    reg.cx := $607;
  reg.bx := 0;
  reg.ax := $0100;
  intr ($10,reg);
end;

Procedure Cursor (a,b : byte);
(* set the cursor to extend from scan line a to scan line b *)
var
  reg : Registers;
begin
  initregisters (reg);
  reg.ch := a;
  reg.cl := b;
  reg.bx := 0;
  reg.ax := $0100;
  intr ($10,reg);
end;

Function Date : String;
(* the date in the format 'MM/DD/YY' *)
var
  y,m,d,w : string;
  Year,Month,Day,DayofWeek,
  i : word;
begin
  GetDate (Year,Month,Day,DayofWeek);
  str (year:4,y);
  delete (y,1,2);
  str (month:2,m);
  str (day:2,d);
  w := m + '/' + d + '/' + y;
  for i := 2 to length(w) do if w[i]=' ' then w[i] := '0';
  date := w;
end;

Function Datec : String;
(* the date in the format 'MM/DD/YYYY' *)
var
  y,m,d,w : string;
  Year,Month,Day,DayofWeek,
  i : word;
begin
  GetDate (Year,Month,Day,DayofWeek);
  str (year:4,y);
  str (month:2,m);
  str (day:2,d);
  w := m + '/' + d + '/' + y;
  for i := 2 to length(w) do if w[i]=' ' then w[i] := '0';
  datec := w;
end;

Procedure DiskAlloc (    Drive : Byte;
                     var Cluster : Integer; var Free, Cap, Used : Longint);
(* get allocation info. for a drive, -1 on error *)
(* cluster size, free space, capacity and space used *)
var
  r : registers;
begin
  initregisters (r);
  r.ah := $36;
  r.dl := drive;
  intr ($21, r);
  if r.ax = $ffff then
    begin
      cluster := -1;
      free := -1;
      cap := -1;
      used := -1;
    end
  else
    begin
      cluster := r.ax*r.cx;
      free := r.bx*longint(cluster);
      cap := r.dx*longint(cluster);
      used := cap - free;
    end;
end;

Function Exist (FN : Pathstr) : Boolean;
(* does a file exist? *)
var
  f  : file;
  a : word;
begin
  Assign (f,FN);
  GetFAttr (f,a);
  Exist := (DosError = 0) and ((a AND (Directory OR VolumeID)) = 0);
  (* NOTE: volume labels cannot actually be detected this way;
           included for compatibility with future versions of DOS *)
end;

Function Exists (FN : Pathstr) : Boolean;
(* does a string exist in the namespace of files? (including directories) *)
var
  f  : file;
  a : word;
begin
  Assign (f,FN);
  GetFAttr (f,a);
  Exists := (DosError = 0);
end;

Function IsDir (FN : Pathstr) : Boolean;
(* is a filename a directory? *)
var
  f  : file;
  a : word;
begin
  Assign (f,FN);
  GetFAttr (f,a);
  IsDir := (DosError = 0) and ((a AND Directory) = Directory);
end;

Function IsLabel (FN : Pathstr) : Boolean;
(* is a filename a volume label? *)
(* NOTE: FN should refer to the root directory of a drive, the only
         place where volume labels are legal. *)
var
  s : searchrec;
begin
  FindFirst (FN, VolumeID, s);
  IsLabel := DosError = 0;
end;

Function IsWritable (FN : Pathstr) : Boolean;
(* is a file writable? *)
var
  f  : file;
  a : word;
begin
  Assign (f,FN);
  GetFAttr (f,a);
  IsWritable := (DosError = 0) and
                ((a AND (Directory OR VolumeID OR ReadOnly)) = 0);
  (* NOTE: volume labels cannot actually be detected this way;
           included for compatibility with future versions of DOS *)
end;

Function GetLabel (Drive : Char) : FileStr;
(* get volume label of a drive *)
var
  s : searchrec;
begin
  FindFirst (Drive+':*.*', VolumeID, s);
  If DosError = 0 then
    begin
      if length(s.name) > 8 then
        delete (s.name, 9, 1);
      GetLabel := s.name;
    end
  else
    GetLabel := '';
end;

Function GetCursor : Word;
(* return current cursor size (restore with Cursor (hi(curs), lo(curs)) *)
var
  reg : registers;
begin
  initregisters (reg);
  reg.ah := $03;
  reg.bh := 0;
  Intr ($10, reg);
  GetCursor := reg.cx;
end;

Procedure InitRegisters (var Reg : Registers);
(* initialize variable of type registers: slightly anal-retentive *)
begin
  fillchar (reg, sizeof(reg), 0);
  reg.ds := dseg;
  reg.es := dseg;
end;

Function PrnOnline (Printernumber : Byte) : Boolean;
(* Is LPT(Printernumber) online? *)
var
  reg : Registers;
begin
  initregisters (reg);
  reg.ah := 2;
  reg.dx := pred(printernumber);
  Intr ($17,reg);
  PrnOnline := (reg.ah AND PrnSelect) = PrnSelect;
end;

Function PrnReady (Printernumber : Byte) : Boolean;
(* Is LPTn ready to accept output (not busy or error)? *)
var
  reg : Registers;
begin
  initregisters (reg);
  reg.ah := 2;
  reg.dx := pred(printernumber);
  Intr ($17,reg);
  PrnReady :=
    ((reg.ah AND (PrnNotBusy OR PrnSelect)) = (PrnNotBusy OR PrnSelect))
    and ((reg.ah AND (PrnIOError AND PrnNoPaper AND PrnTimeout)) = 0);
end;

Function PrnStatus (Printernumber : Byte) : Byte;
(* return status of LPTn with undefined bits masked off *)
var
  reg : Registers;
begin
  initregisters (reg);
  reg.ah := 2;
  reg.dx := pred(printernumber);
  Intr ($17,reg);
  PrnStatus := (reg.ah AND $F9);  (* mask off the two unused bits *)
end;

Function PrnErr (Err : Byte) : String;
(* attempt to produce error message from status of printer *)
begin
  PrnErr := '';
  if (Err AND PrnNoPaper) = PrnNoPaper then PrnErr := 'Out of Paper'
  else
    if (Err AND PrnTimeout) = PrnTimeout then PrnErr := 'Timeout'
    else
      if (Err AND PrnSelect) = 0 then PrnErr := 'Off Line'
      else
        if (Err AND PrnIOError) = PrnIOError then PrnErr := 'I/O Error'
        else
          if (Err AND PrnNotBusy) = 0 then PrnErr := 'Busy';
end;

Function Time : String;
(* time in the format '20:44:32' *)
var
  h,m,s,w : string;
  hour,min,sec,sec100,
  i : word;
begin
  GetTime (hour,min,sec,sec100);
  str (hour:2,h);
  str (min:2,m);
  str (sec:2,s);
  w := h + ':' + m + ':' + s;
  for i := 2 to length(w) do if w[i]=' ' then w[i]:='0';
  time := w;
end;

Function Timen : String;
(* time in the format '20:44' *)
var
  h,m,w : string;
  hour,min,sec,sec100,
  i : word;
begin
  GetTime (hour,min,sec,sec100);
  str (hour:2,h);
  str (min:2,m);
  w := h + ':' + m;
  for i := 2 to length(w) do if w[i]=' ' then w[i]:='0';
  timen := w;
end;

Function WeekDay : String;
(* return the current day of week in English *)
var
  Year,Month,Day,DayOfWeek : word;
begin
  GetDate (Year,Month,Day,DayOfWeek);
  case DayOfWeek of
    0 : WeekDay := 'Sunday';
    1 : WeekDay := 'Monday';
    2 : WeekDay := 'Tuesday';
    3 : WeekDay := 'Wednesday';
    4 : WeekDay := 'Thursday';
    5 : WeekDay := 'Friday';
    6 : WeekDay := 'Saturday';
  else
    WeekDay := '';
  end;
end;

End.