program harddisk;
{ manipulate harddisk through interrupt 25h 26h calls }

type
  anystring = string[255];
  regpak = record
           ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
           end;
  buffer = array[0..4095] of byte; { provide for largest sector size }
  bpb    = record   { boot parameter block }
              sectorsize : integer;
              sectorsalloc : byte; { sectors per allocation }
              reserved : integer;
              fats     : byte;
              directory_entries  : integer;
              sectors     : integer;
              media    : byte;
              fatsectors  : integer;
              spt      : integer;
              heads    : integer;
              hidden   : integer;
              unit     : byte;
              end;

bpbptr = ^bpb;

dosdir  =

    record

      filename                :  array[0..7] of byte;
      extension               :  array[0..2] of byte;
      attribute               :  byte;  { hidden = 2; system = 4 }
      reserved                :  array [1..10] of byte;
      creation_time           :  integer; { hour * 2048 + minute * 32 + secs }
      creation_date           :  integer; {(year-1980) * 512 + month * 32 + day}
      starting_cluster_number :  integer;
      filesize                :   array [1..2] of integer;

    end;

dirptr = ^dosdir;

const
   RETRIES   = 1; { number of retries before marking as bad }
   CARRYFLAG = $01;
   drivemax =  15;
   MAXSEC   =  32000;
   CALL     =  $E8 ; { 16 bit short call }
   NOP      =  $90 ; { nop for patching }
   POPBX    =  $5B ; { pop bx }
   INT      =  $CD ;
   ABSREAD  =  $25 ;

var

  reg : regpak;
  c   : char;
  sectorbuffer : buffer;
  logon : boolean;
  errorlog : text;
  logname : string[40];
  drivename : string[20];
  startsector, lastsector : integer;
  drivenumber : integer;





procedure presscrlf;
var ch : char;
begin
 writeln;
 writeln('Press <CR> to continue.');
 repeat read(kbd,ch) until ch =#$0d;
 writeln;
end;

{ display module }
const
   hexint : string[16] = '0123456789ABCDEF';

procedure putnibble(x: integer);
begin
   x:=x and $0f;
   write(hexint[x+1]);
end;

procedure putbyte ( x: integer);
begin
   x:= x and $ff;
   putnibble((x and $f0) shr 4);
   putnibble( x and $0f);
end;

procedure puthex(x : integer );
begin

  putbyte(hi(x));
  putbyte(lo(x));
end;

function filter( x : byte ) : char;
{ strips high bit, if not printing, returns '.'}
begin
   x:=x and $7f;
   case x of
     0..31 : filter:='.';
     32..126 : filter:=chr(x);
     127..255 : filter:='.';
   end; { case }
end;

type
    byte16 = array[0..15] of byte;
    byte16ptr = ^byte16;


procedure ascii16( z : byte16ptr);
{ print out 16 consecutive bytes in filtered ascii, with fence }
var i : integer;
begin
  write('  | '); { fence }
  for i:=0 to 15 do write(filter(z^[i]));
  writeln(' |');
end; { ascii16 }

procedure hex16 ( z : byte16ptr);
{ print 16 consecutive bytes in hex, no cr/lf, space between each 4 }
var i,j : integer;
begin
   for j:= 0 to 3 do begin
       for i:=0 to 3 do putbyte(z^[i+(j*4)]);
       write(' ');
   end;
end; { hex16 }

procedure oneline( x: integer ; z : byte16ptr);
begin
  putbyte(hi(x));
  putbyte(lo(x));
  write('  ');
  hex16(z);
  ascii16(z);
end;

procedure page;
var i,j : integer;
    ch : char;
begin
   for i:= 0 to 15 do begin
      oneline(16*i,ptr(seg(sectorbuffer[16*i]),ofs(sectorbuffer[16*i])));
   end;
   writeln;writeln('Press a key to continue');read(kbd,ch);writeln;
   for i:= 16 to 31 do begin
      oneline(16*i,ptr(seg(sectorbuffer[16*i]),ofs(sectorbuffer[16*i])));
   end;
end; { page }




{ end of display module }

procedure logo;
begin
  writeln;writeln;writeln;
  writeln('Copyright 9-1-85 Clarence W. Wilkerson, Jr.');
  writeln('All rights reserved. Permission granted for');
  writeln('non-commercial use only.');
  writeln;
  writeln('This program uses DOS interrupt 25H to read records');
  writeln('from a disk to check for validity of the data. An');
  writeln('optional error log is generated to record any bad');
  writeln('sectors found. Use mode R for this. Mode P prints');
  writeln('to the screen the disk parameters, and E dumps the');
  writeln('sector to the screen in hex and ASCII. This program');
  writeln('performs no write operations other than the error');
  writeln('logging, but use at your own risk.');
  writeln;
  writeln;writeln;
  presscrlf;
end;      { logo }

{ dos interrupt stuff }
procedure initreg(drive,sector: integer );
begin
   with reg do begin
     { clear unused flags }
     bp :=0;si:=0;di:=0;es:=0;flags:=0;
     ax:= drive and $0f;
     bx:= ofs(sectorbuffer);
     ds:= seg(sectorbuffer);
     cx:= 1;
     dx:= sector;
  end;
end; { initreg }

function patch : boolean;
var goodpatch,foundit : boolean;
    i,j,x,y :        integer;

{ must find $cd/$25/$E8/XX/XX/NOP/NOP before considered valid }
{ patches to $cd/$25/POPBX/CALL /XX/XX-1/ }

{ Dos $25 and $26 leave old flags at top of stack, with
new flags as current flags. To prevent the machine from going to
never-never-land, we must pop the old flags into something expendable.
Since we need flags to show error, and al to point to error, pop
into bx to be safe }

begin
      i:=$100; { begin search }
      repeat
         foundit:=false;
         x:=mem[cseg:i];
         if  x = INT then begin
              {write('!')};
              x:=mem[cseg:(i+1)]; { check for ABSREAD }
              if x = ABSREAD then begin
                 {write('@')};
                 x:=mem[cseg:(i+2)];
                 if x = CALL then begin
                    {write('#')};
                    x:=memw[cseg:(i+5)];
                    if x = (NOP + (nop shl 8)) then begin
                       {write('$')};
                       foundit:=true;
                    end;
                  end;
               end;
            end;
         if not foundit then i:=i+1;
      until ( hi(i) > $f0) or  foundit;
      if foundit then begin
         goodpatch:=true;
         y:=memw[cseg:(i+3)];
         y:=y-1; { adjust }
         mem[cseg:(i+2)]:=POPBX;
         mem[cseg:(i+3)]:=CALL;
         memw[cseg:(i+4)]:=y;
       end  else begin
          goodpatch:=false;
          writeln('No int 25 call found.');
          writeln;
       end;
  patch:=goodpatch;
  end; { patch }


function doread : integer;
begin
         intr($25,reg);
         inline($90/$90/$90/$90/$90); { room to put pop bx once to restore stack }
         { also allows the patch area to be recognized }
         doread:=(lo(reg.ax) shl 8) or lo(reg.flags);
end; { doread }

{ end of dos interrupt stuff }

procedure initbuffer;
var i : integer;
begin
  for i:=0 to 511 do sectorbuffer[i]:=$ff;
end;  { initbuffer }

function getlog : boolean;
var   logon : boolean;
begin
   write('Name of disk file to log bad sectors <NONE>.. ');
   readln(logname);
   if length(logname) = 0 then begin
      logon:=false;
   end else begin
      assign(errorlog,logname);
      {$I-}
      rewrite(errorlog);
      {$I+}
      if (ioresult<> 0) then begin
          writeln('Can''t open ',logname,' . No log written.');
          {$I-}
          close(errorlog);
          {$I-}
          logon:=false;
       end else logon:=true;
   end;
   getlog:=logon;
end; { getlog }

procedure getbounds;
begin
  repeat
      write('Starting relative sector ? '); readln(startsector);
  until (startsector >=0) and (startsector < MAXSEC);

  repeat
      write('Ending relative sector ?   '); readln(lastsector);
  until (lastsector >=0) and (lastsector < MAXSEC);
end; { getbounds }

procedure getdrive;
var ch : char;
begin
  repeat
      write('Which drive? ');
      readln(drivename);
      ch:=upcase(drivename[1]);
      drivenumber:=ord(ch) - ord('A');
  until (ch in ['A'..'P']) and (drivenumber < drivemax);
 end; { getdrive }


procedure summary;
begin
   writeln;writeln;
   writeln('Reading drive  ',chr($41+drivenumber),':  from sector ',startsector,' to ',lastsector);
   if logon then writeln('Error log to file ',logname) else
   writeln('No error log.');
   writeln;writeln;
 end; {summary }

procedure getinfo;
begin

   writeln;
   getdrive;
   getbounds;
   logon:=getlog;
   summary;  { print statistics }
   writeln;
   writeln('Reading sector ');
end;

procedure getsector;
label 1111;
var i : integer;
    c : char;
    x,reassure : integer;
begin
   reassure:=0;
   for i:=startsector to lastsector do begin
       initreg($0f and drivenumber,i);
       x:=doread;
       reassure:=reassure+1;
       if reassure = 10 then begin
            reassure:=0;
            write(#$0D,'       ',#$0d,i:5);
        end;
        if (x and CARRYFLAG) <> 0 then begin
            write('Drive  ',chr($41+drivenumber),':   Sector ',i);
            writeln(' Error code  ', hi(x));
            if logon then writeln(errorlog,i,'   ',hi(x));
         end;
         if keypressed then read(kbd,c);
           { the check for ^S and ^C steals the characters, so this doesn't
                work the way you think }
         if c=chr($1a) then goto 1111;
   end; { for }
   1111:
      if logon then close(errorlog);
end;  { getsector }

procedure checksector;
begin
  getinfo;
  getsector;
end;



procedure showparams;
var x : bpbptr;

begin
    x:=ptr(seg(sectorbuffer[$0b]),ofs(sectorbuffer[$0b]));

    if  hi(x^.sectorsize) in [1,2,4,16] then begin

    writeln;writeln;writeln;
    writeln('Dos Boot Parameter Block from sector 0, bytes 0bH-1fH.');
    writeln('Used on Dos 2.X and higher. This information may not be');
    writeln('present on DOS 1.X formatted disks, or on device driver');
    writeln('activated disk units.');
    writeln;
    writeln;
    writeln('Sector size in bytes............',x^.sectorsize);
    writeln('Sectors per allocation block....',x^.sectorsalloc);
    writeln('Reserved sectors................',x^.reserved);
    writeln('Number of FATS..................',x^.fats);
    writeln('Number of directory entries.....',x^.directory_entries);
    writeln('Total sectors on disk...........',x^.sectors);
    write('Media identification byte.......');
    putbyte(x^.media );
    writeln;
    writeln('Sectors per track...............',x^.spt);
    writeln('Heads per cylinder..............',x^.heads);
    writeln('Hidden sectors..................',x^.hidden);
    writeln('Unit number.....................',x^.unit);
end else writeln('Sorry, this disk does not have a standard BPB in sector 0');

    presscrlf;
end;


procedure getbpb;
begin
    getdrive;

    startsector:=0;
    lastsector:=0; { read first sector }
    logon:=false;
    getsector;
    showparams;
 end;   { get bpb }

procedure printdir( x : dirptr);
{ show one directory entry }
var y : real;
    i : integer;
begin
 if not ( x^.filename[0] in [$e5,0]) then begin
     for i:=0 to 7 do write( chr(x^.filename[i] and $7f));write('  ');
     for i:=0 to 2 do write(chr(x^.extension[i] and $7f));write('  ');
     putbyte(x^.attribute);
     write('        ');
     y:=lo(x^.starting_cluster_number) + 256.0*hi(x^.starting_cluster_number);
     write(y:6:0);
     write('    ');
     y:=lo(x^.filesize[1])+ 256.0*hi(x^.filesize[1])
     + 65536.0*((lo(x^.filesize[2]) + 256.0*hi(x^.filesize[2])));
     writeln('         ',y:10:0);
  end; { don't print empty or erased entries }
 end; { printdir }

procedure showdir; { interprets current contents of sectorbuffer[0..511]
as directory entries, and prints them out }
var i : integer;
    x : dirptr;
begin
    writeln;writeln;

    writeln(' File name     Attr.      Starting cluster    File size  ');
    for i:=0 to 15 do begin
        x:=ptr(seg(sectorbuffer[i shl 5]),ofs(sectorbuffer[i shl 5]));
        printdir(x);
    end;
end; { show dir }


procedure mksector(n: integer; var ss, ls : integer);
var
    x : bpbptr;
    nsize,secperalloc,nfats,ndirs,dirsecs,nres,tfat : integer;
begin { convert allocation block to absolute sector numbers }
      { limits returned in ss and ls }
    startsector:=0;
    lastsector:=0; { read first sector }
    logon:=false;
    getsector;
    x:=ptr(seg(sectorbuffer[$0b]),ofs(sectorbuffer[$0b]));
    secperalloc:=x^.sectorsalloc;
    nfats:=x^.fats;
    ndirs:=x^.directory_entries;
    nres:=x^.reserved;
    nsize:=x^.sectorsize;
    { compute sectors for directory entries }
    dirsecs:= ndirs shl 5; { mult by 32 }
    dirsecs:=dirsecs div nsize;
    tfat:= x^.sectors div secperalloc;
    tfat:= (3* tfat) div 2;
end;

procedure examine; { display the sector in ascii and hex }
var ch : char;
    response : boolean;
    answer : string[20];
    code   : integer;
    allocblk : integer;
    issector : boolean;
    i,lsector,ssector : integer;
begin
   getdrive;
 repeat
   issector:=true; { by sectors }
   write('Absolute sector number? ' );
   readln(answer);
   val(answer,startsector,code);
   if length(answer)= 0 then begin { default to allocation block }
      code:=0;
      issector:=false;
      write('Which allocation block? ');
      readln(answer);
      val(answer,allocblk,code);
   end
 until code=0;
   logon:=false;
 if issector then
 repeat
   lastsector:=startsector;
   getsector;
   writeln;writeln('Sector ', startsector, ' of drive ',chr($41+drivenumber),':');
   writeln;
   page;
   writeln;
   writeln('Type SPACE to continue, - to reverse, / to interpret as directory');
   writeln('or <CR> to return to menu.');
   read(kbd,ch);
   case ch of
      ' ' : startsector:=startsector+1;
      '-' : startsector:=startsector-1;
      '/' : begin
              showdir;
              startsector:=startsector+1;
              presscrlf;
            end;
   end
 until ch = #$0d
 else { show the whole allocation block } begin
     mksector(allocblk,ssector,lsector);
     for i:= ssector to lsector do begin
        lastsector:=startsector;
        getsector;
        writeln;writeln('Sector ', startsector, ' of drive ',chr($41+drivenumber),':');
        writeln;
        page;
        writeln;
     end; { for i }
  end; { else }
end; { examine }

function menu : char;
var  c:char;
begin
  writeln;
  writeln('P....show disk parameters');
  writeln;
  writeln('E....examine a sector');
  writeln;
  writeln('R....check a group of sectors for errors');
  writeln;
  writeln('Q....return to DOS');
  writeln;
  write('Your choice ?  ');
  read(kbd,c);writeln(c);
  menu:=upcase(c);
end; { menu }

begin  { main }
  logo;
  initbuffer;
if patch then
  while true do begin
     repeat
       writeln;
       c:=menu
    until c in ['P','E','Z','X','Q','R',#$1a];
    case c of
      'P' : getbpb;
      'R' : checksector;
      'E' : examine;
      'X','Q','R',#$1A,'Z' : halt;
       else begin end; { do nothing for default }
    end;{ case }
  end { while }
 else begin
      writeln('Cannot patch int 25 call. Press <CR> to abort.');
      readln;
      halt;
 end;
end.