{$F+}   (* to get dos 25 assembly code to work use all far calls *)

program nortonlike;
(* updated to TP 5.0 *)

{ manipulate disks, including harddisk through interrupt 25h, 26h calls
  make sure ABSREAD.OBJ is available

; by CWW, cribbed from dump of turbo c library
; to implement absread, abswrite as in turbo c
; for turbo pascal 4.0.. 5.x

     .MODEL TPASCAL
     .CODE
;  function absread(drive,first, howmany: word ;
;                  dest : bufptr ) : word;
absread  PROC FAR drive:word, first:word,howmany:word,dest:dword RETURNS rerror:word
   PUBLIC absread
   mov  ax, drive ; get drive
   and  ax, 00ffh ; make it a byte
   mov  cx, howmany ; get number of sectors
   mov  dx, first;    get first sector
   push ds
   lds  bx,dest
   int  25h
   pop  bx  ; gets old flags out of way
   pop  ds  ; get right data segment back
   jc   short errorexit
   xor   ax,ax;
   jmp short  myexit;
errorexit:     ; see if return works
;   mov ax, -1 ; signal error
myexit:
   mov rerror,ax
   ret
endp


abswrite  PROC FAR drive:word, first:word,howmany:word,source:dword RETURNS werror:word
   PUBLIC abswrite
   mov	ax,drive   ; get drive
   and  ax, 00ffh  ; make it a byte
   mov  cx,howmany ; get number of sectors
   mov  dx, first  ; get first sector
   push ds
   lds  bx, source
   int  26h
   pop  bx  ; gets old flags out of way
   pop  ds  ; get right data segment back
   jc   short werrorexit
   xor  ax,ax;
   jmp  short  wmyexit;
werrorexit:  ; see if return works
;   mov ax, -1 ; signal error
wmyexit:  mov  werror,ax
   ret

endp

   END
}

uses dos,crt,printer;
type
  mystring  = string[64];
  anystring = string[255];
  buffer = array[0..16383] of byte; { provide for directory size of 512 entries }
  { and largest cluster size }
  bufptr = ^buffer;
  bpb    = record   { boot parameter block }
              sectorsize : word;
              sectorsalloc : byte; { sectors per allocation }
              reserved : word;
              fats     : byte;
              directory_entries  : word;
              sectors     : word;
              media    : byte;
              fatsectors  : word;
              spt      : word;
              heads    : word;
              hidden   : word;
              unitno   : 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           :  word; { hour * 2048 + minute * 32 + secs }
      creation_date           :  word; {(year-1980) * 512 + month * 32 + day}
      starting_cluster_number :  word;
      filesize                :  longint;

    end;

dirptr = ^dosdir;

const
   RETRIES   = 1; { number of retries before marking as bad }
   CARRYFLAG = $01;
   drivemax =  15;
   MAXSEC   =  $f400;

var
  reg : registers;
  c   : char;
  sectorbuffer : buffer;
  logon : boolean;
  errorlog : text;
  logname : string[40];
  drivename : string[20];
  canread, canwrite, havelogged : boolean;


  (* magic numbers used to convert to clusters and back *)
  (* these are figured out using dos calls and reading sector 0 *)

  maxalloc : word; (* number of clusters on disk *)
  maxsectors : word; (* number of sectors on disk *)
  sectorcluster : word; (* number of sectors per cluster *)
  numdir_sectors : word; (* number of sectors used by directory *)
  fatsectors : word; (* number of sectors used by each fat *)
  numresv_sectors : word; (* number of reserved sectors *)
  fatnumber : word; (* number of fat tables *)
  firstdir  : word; (* first directory sector *)
  cluster2  : word; (* first sector of cluster 2 *)
  bytessector : word; (* bytes per sector, almost always 512 *)
  dirs_per_sector : word; (* number of directory entries per sector *)

  abserror : integer;

procedure beep;
begin
  write(#7,#7,#7);
end; (* beep *)


function absread(drive,first,howmany: word ; dest : bufptr ) : integer; external;
function abswrite(drive,first, howmany: word ; source : bufptr) : integer; external;

{$L absread }



function max(x,y : longint) : longint;
begin
   if x >=y then max:=x else max:=y;
end; { max }

procedure putlarge( x : integer);
{ put out unsigned integer }
var y : longint;
begin
  if x >= 0 then y:=x;
  if x < 0 then y:= x + 65536;
  write(y:0);
end; { putlarge }

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

procedure pressspace;
var ch : char;
begin
 writeln;
 writeln('Press <SPACE> to continue.');
 repeat ch:=readkey until ch =' ';
 writeln;
end;

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

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

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

procedure puthex(x : word );
begin
  putbyte(hi(x));
  putbyte(lo(x));
end;

procedure fputnibble(var f: text; x: word);
begin
   x:=x and $0f;
   write(f, hexint[x+1]);
end;

procedure fputbyte (var f:text; x: word);
begin
   x:= x and $ff;
   fputnibble(f,(x and $f0) shr 4);
   fputnibble(f, x and $0f);
end;

procedure fputhex(var f : text; x : word );
begin
  fputbyte(f,hi(x));
  fputbyte(f,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: word ; z : byte16ptr);
begin
  putbyte(hi(x));
  putbyte(lo(x));
  write('  ');
  hex16(z);
  ascii16(z);
end;


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

procedure fhex16 (var f: text;  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 fputbyte(f,z^[i+(j*4)]);
       write(f,' ');
   end;
end; { fhex16 }

procedure foneline(var f : text;  x: word ; z : byte16ptr);
begin
  fputbyte(f,hi(x));
  fputbyte(f,lo(x));
  write(f,'  ');
  fhex16(f,z);
  fascii16(f,z);
end;

procedure page;
label 1000;
var i,j : integer;
    ch : char;
begin
   for i:= 0 to 15 do begin
      oneline(16*i,addr(sectorbuffer[16*i]));
   end;
   writeln;writeln('Press <SPACE> to continue, anything else to skip..');
   ch:=readkey;if ch=' ' then writeln else goto 1000;
   for i:= 16 to 31 do begin
      oneline(16*i,addr(sectorbuffer[16*i]));
   end;
 1000:
end; { page }

{ end of display module }


function xlatesector( sec : word ) : word;
(* for now use formula for  seagate drive *)
begin
 if sec < firstdir then begin xlatesector := 0 ; exit;end;
 if sec < cluster2 then begin xlatesector := 1 ; exit;end;
 xlatesector:= ( sec -cluster2) div sectorcluster + 2;
end; (* xlate *)

function xlatecluster( cluster : word ) : word;
(* for now use formula for  seagate drive *)
begin
    if cluster= 0 then begin xlatecluster:= 0  ; exit ;end;
    if cluster= 1 then begin xlatecluster:= firstdir; exit ;end;
    xlatecluster:= (cluster -2) * sectorcluster   + cluster2;
end; (* xlate *)

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.');
  writeln;
  writeln;writeln;
  pressspace;
end;      { logo }

{ dos interrupt stuff }


procedure initbuffer;
var i : integer;
begin
  for i:=0 to 511 do sectorbuffer[i]:=$00;
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(var start, finish : word);
begin
  repeat
      write('Starting sector ? ');
      readln(start);
  until (start >= 0) and (start < maxsectors);

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

var drivenumber : word;   (* private data *)

function getdrive: integer;
var ch : char;
begin
  if havelogged then getdrive:= drivenumber
  else getdrive:= $FF;
end; (* getdrive *)




procedure getinfo(drive,start,finish: word );

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

begin
   writeln;
   if getdrive = $ff then exit;
   getbounds(start,finish);
   logon:=getlog;
   summary;  { print statistics }
   writeln;
   writeln('Reading sector ');
end;

function getsector(drive,start,finish: word): boolean;
label 1111;
var i : word;
    c : char;
    x,reassure : integer;
    count : word;
    buffy : bufptr;
    temp : boolean;
begin
   temp:=true;
   reassure:=0;
   count:=1;
   buffy:=addr(sectorbuffer[0]);
   for i:=start to finish do begin
       x:= absread(drive,i,count,buffy);
       abserror:=x;
       reassure:=reassure+1;
       if reassure = 10 then begin
            reassure:=0;
            write(#$0D,'       ',#$0d,i:5);
        end;
	if (x  <> 0 )then begin
	    temp:=temp and false;
	    write('Drive  ',chr($41+drive),':   Sector ',i);
            write(' Error ');puthex(word(x));writeln;
	    if logon then  begin
		write(errorlog,'Sector i ',i:6); puthex(word(x));writeln;
	    end;
	 end;
         if keypressed then c:=readkey;
           { 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);
      getsector:=temp;
end;  { getsector }

procedure checksector;
var drive,start,finish : word;
begin
  drive:=getdrive;
  getinfo(drive,start,finish);
  if not getsector(drive,start,finish) then exit;
end;

procedure getdosparameters( drive : byte);
{ use call 1ch to see what dos thinks the parameters are }
var  u : registers;
begin
   u.ax:=$1c shl 8;
   u.dx:=drive + 1;
   msdos(u);
   writeln;
   writeln('From DOS call $1C the parameters are ');
   writeln;
   writeln('Bytes per sector....           ',u.cx:5);
   writeln('Sectors per allocation unit    ',lo(u.ax):5);
   writeln('Number of allocation units     ',u.dx:5);
   maxalloc:= u.dx;
   maxalloc:= u.dx;
   sectorcluster:= lo(u.ax);
   bytessector:=   u.cx;
   dirs_per_sector :=   bytessector div 32;
   write  ('FAT id. byte                      '); putbyte(mem[u.ds:u.bx]);
   writeln;
end; { get dos parameters }

procedure quietgetdosparameters( drive : byte);
{ use call 1ch to see what dos thinks the parameters are }
{ use this to set cluster size in sectors }
var  u : registers;
begin
   u.ax:=$1c shl 8;
   u.dx:=drive + 1;
   msdos(u);
   maxalloc:= u.dx;
   sectorcluster:=      lo(u.ax);
   bytessector:=        u.cx;
   dirs_per_sector :=   bytessector div 32;

end; { get dos parameters }


procedure showparams;
var x : bpbptr;
    numdir_sectors: word;
begin
    getdosparameters(drivenumber);
    x:=addr(sectorbuffer[$0b]);
 if  hi(x^.sectorsize) in [1,2,4,16] then begin
    clrscr;
    writeln('Dos Boot Parameter Block from sector 0, bytes 0bH-1fH.');
    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);
    numdir_sectors:=  x^.directory_entries div ( (x^.sectorsize) div 32 );
    write  ('Total sectors on disk...........');

    maxsectors:=x^.sectors;
    numdir_sectors:= x^.directory_entries div dirs_per_sector;
    fatsectors:= ( (maxalloc * 2) + (bytessector -1)) div bytessector ;
    numresv_sectors:=x^.reserved;
    firstdir:= numresv_sectors + x^.fats * fatsectors;

    write(x^.sectors:6); writeln;
    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^.unitno);
    writeln;
    (* now compute where things are *)
    writeln('Number of directory sectors.....',numdir_sectors);
    writeln('Sectors in each FAT.............', fatsectors);
    (* number of clusters * 2 or 1.5 / sector size, rounded up *)

    writeln('First directory sector..........',firstdir);
    (* reserved + 2 * FAT *)
    cluster2:= firstdir + numdir_sectors;
    writeln('Beginning of cluster 2..........',cluster2);
    (* + number of directory sectors *)
    writeln('Number data clusters  ..........', maxalloc -2);
    (* what's left *)
end else begin
    writeln;
    writeln('Sorry, this disk does not have a standard BPB in sector 0');
    writeln;
end;
    writeln;
    pressspace;
end;

procedure quietshowparams(drive : word);
var x : bpbptr;
begin
    quietgetdosparameters(drive);
    x:=addr(sectorbuffer[$0b]);
 if  hi(x^.sectorsize) in [1,2,4,16] then begin
    numdir_sectors:=  x^.directory_entries div ( (x^.sectorsize) div 32 );
    maxsectors:= x^.sectors;
end else begin
    writeln;
    writeln('Sorry, this disk does not have a standard BPB in sector 0');
    writeln;
end;
end;  (* quitgetbpb *)


procedure getbpb;
var drive, sector : word;
begin
    drive:= getdrive;
    sector:=0; { read first sector }
    logon:=false;
    if not getsector(drive,sector,sector)then begin
       writeln;
       writeln('Error on reading BPH sector');
       exit;
    end;
    showparams;
 end;   { get bpb }

procedure quietgetbpb(drive : word);
var  sector : word;
begin
    sector:=0; { read first sector }
    logon:=false;
    if not getsector(drive,sector,sector)then begin
       writeln;
       writeln('Error on reading BPH sector');
       exit;
    end;
    quietshowparams(drive);
 end;   { get bpb }

procedure printdir( x : dirptr);
{ show one directory entry }

var numclusters,firstcluster,lastcluster,size,y,z : longint;
    i : longint;
begin
 if not ( x^.filename[0] in [$e5,0]) then begin
     for i:=0 to 7 do write( filter(x^.filename[i] and $7f));write('  ');
     for i:=0 to 2 do write( filter(x^.extension[i] and $7f));write('  ');
     putbyte(x^.attribute);
     size:= x^.filesize;
     write('    ',size:10);
  write('    ');
  firstcluster:= x^.starting_cluster_number;
     write(firstcluster:6);
     write('      ');
  numclusters:= size div 2048;
  lastcluster:= firstcluster + numclusters;
  writeln(lastcluster:6);
end; { don't print empty or erased entries }
 end; { printdir }

procedure fprintdir(var f : text ;  x : dirptr; limit : word);
{ show one directory entry, use hex notation too }
var numclusters,firstcluster,lastcluster,size,y,z : longint;
    i : integer;
begin
 if not ( x^.filename[0] in [$e5,0]) then begin
     firstcluster:= x^.starting_cluster_number;
  if firstcluster < limit then begin
     for i:=0 to 7 do begin
         write(f, filter(x^.filename[i]));
     end;
     write(f,' ');
     for i:=0 to 2 do begin
         write(f, filter(x^.extension[i]));
     end;
     write(f,'  ');
     fputbyte(f,x^.attribute);
     size:= x^.filesize;
     write(f,'    ',size:10);
     write(f,'    ');
     write(f,firstcluster:6);
     write(f,'  ');
     fputhex(f,firstcluster);
     write(f,'  ');
     numclusters:= size div ( sectorcluster * bytessector);
     lastcluster:= firstcluster + numclusters;
     write(f,lastcluster:6); write(f,' ');
     fputhex(f,word(lastcluster));writeln(f);
   end;
  end; { don't print empty or erased entries, or after limit }
end; { fprintdir }

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.  File size   First cluster  Possible Last cluster' );
    for i:=0 to (dirs_per_sector -1) do begin
        x:=addr(sectorbuffer[i shl 5]);
        printdir(x);
    end;
end; { show dir }

procedure fshowdir(var f : text ; b : bufptr; limit : word); { interprets current contents of sectorbuffer[0..511]
as directory entries, and prints them out }
var i : integer;
    x : dirptr;
begin
writeln(f);

writeln(f,' File name     Attr.  File size   First cluster  Possible Last cluster' );
    for i:= 0 to (dirs_per_sector -1) do begin
        x:=addr(b^[i shl 5]);
        fprintdir(f,x,limit);
    end;
end; { fshowdir }


procedure
cluster_fshowdir(var f : text ; b : bufptr; limit : word; shorter: boolean );
{ interprets current contents of sectorbuffer[0..511]
as directory entries, and prints them out }
var i : integer;
    x : dirptr;
begin
   writeln(f);
   writeln(f,' File name     Attr.  File size   First cluster      Possible Last cluster' );
   if shorter then for i:= 0 to 63 do begin
        x:=addr(b^[i shl 5]);
        fprintdir(f,x,limit);
   end
   else if not shorter then
        for i:= 0 to 511 do begin
           x:=addr(b^[i shl 5]);
           fprintdir(f,x,limit);
   end;
end; { cluster_fshowdir }


procedure mksector(drive: word ; var ss, ls : integer);
var
    x : bpbptr;
    start: word;
    nsize,secperalloc,nfats,ndirs,dirsecs,nres,tfat : integer;
begin { convert allocation block to absolute sector numbers }
      { limits returned in ss and ls }
    start:=0;
    havelogged:=false;
    if not getsector(drive,start,start) then exit;
    x:=addr(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 }
label  1120;
var ch : char;
    response : boolean;
    answer : string[20];
    code   : integer;
    allocblk : integer;
    issector : boolean;
    i,sector : word;
    drive : word;
begin
   drive:=getdrive;
 repeat
   issector:=true; { by sectors }
   write('Absolute sector number? ' );
   readln(answer);
   val(answer,sector,code);
 until (code=0) or (upcase(answer[1])='X');
 if upcase(answer[1])='X' then goto 1120;
 logon:=false;
 repeat
   if not getsector(drive,sector,sector) then beep;
   writeln;
   write('Sector ', sector, '  ');
   puthex(sector);
   writeln('H of drive ',chr($41+drive),':');
   writeln;
   page;
   writeln;
   writeln('Type SPACE to continue, - to reverse, / to interpret as directory');
   writeln('or <CR> to return to menu.');
   ch:=readkey;
   case ch of
      ' ' : sector:=sector+1;
      '-' : sector:=sector-1;
      '/' : begin
              showdir;
	      sector:=sector+1;
              pressspace;
            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;
        write('Sector ', startsector, '   ');
        puthex(startsector);
        writeln('H  of drive ',chr($41+drivenumber),':');
        writeln;
        page;
        writeln;
     end; { for i }    *)
  1120:
end; { examine }


function is_dir ( b : bufptr) : boolean;
(* looks at current disk buffer and tries to guess if it is a
   directory
   criterion used are simplistic.. want to get all real entries for sure
   and leave off junk:
   1) bytes 1...11 are ascii UPPER CASE, or byte 1 is E5 or 0
   2) bytes 12 .. 20 are null
   Note that some versions of dos seem to leave all bytes zero in unused
   directory slots, so don't exclude these
*)
var k,j,l : word;

function is_ascii( x : byte) : boolean;
begin
   (* suspect will be mostly false tests; *)
   is_ascii:=false;
   if x and $80 <> 0 then exit;
   if x < 32 then exit;
   if (x > 96) and ( x < firstdir) then exit; (* only use caps *)
   if x > 126 then exit;
   is_ascii:= true;
end;  (* is_ascii *)

function is_xascii( x : byte) : boolean;
begin
   is_xascii:= true;
   if x = 0 then exit; (* directories get filled with zeros sometimes *)
   if x = $e5 then exit; (* directories get filled with zeros sometimes *)
   is_xascii:=true;
   if x and $80 <> 0 then exit;
   is_xascii:=is_ascii(x);
end;  (* is_xascii *)

begin  (* test first few  entries *)
   is_dir:=false;
 (* test first entry for cap letter or 0 or $E5 *)
   L:= 0;
 for j:= 0 to ( sectorcluster*dirs_per_sector -1) do begin (* do quick check of all entries in this cluster*)
   if  not is_xascii(b^[L]) then exit; (* ascii or 0 or E5 *)
   L:=L+16;
   if b^[L] <> 0 then exit;
   L:=L+16;
 end;
 for j:= 0 to (dirs_per_sector -1)  do begin (* do all entries in this sector *)
   L:= j shl 5;
   for k:= 1 to 10   do if not is_ascii(b^[k + L] ) then exit;
   for k:=12 to 20   do if b^[k + L ] <> 0 then exit;
 end;  (* j *)
 is_dir:= true;
end;  (* is_dir *)



function scandir( start : word): word;
(* start at sector start and find first sector after it which
   looks like a directory
*)
var  nextsector : word;
     error,drive,count : word;
     time2stop : boolean;
     buffy : bufptr;
begin
  count:=1;
  drive:=getdrive;
  scandir:=start;
  time2stop:=false;
  buffy:=addr(sectorbuffer[0]);
  repeat
     start:=start +1;
     error:= absread(drive,start,count,buffy);
     abserror:=error;
     if error <> 0 then begin
        beep;
        write('Drive  ',chr($41+drive),':   Sector ',start);
        write(' Error ');puthex(word(error));
        writeln;
     end
     else time2stop:=is_dir(buffy);
    if start and $3f = 0 then
        writeln('Scanning sector ',start:6,' for directory');
  until   time2stop or (start > maxsectors) ;
  scandir:=start;
end;  (* scandir *)


function absioerr: integer;
begin
   absioerr:=abserror;
   abserror:=0;
end;

function cluster_scandir( startcluster : word): word;
(* start at cluster start and find cluster sector after it which
   looks like a directory
*)
var  nextsector : word;
     sector, error,drive,count : word;
     time2stop : boolean;
     buffy : bufptr;
begin
  drive:=getdrive;
  time2stop:=false;
  buffy:=addr(sectorbuffer[0]);
  repeat
     startcluster:= startcluster +1;
     if startcluster > 1 then
       count:=sectorcluster
     else count:= numdir_sectors;
     sector:= xlatecluster(startcluster);
     error:= absread(drive,sector,count,buffy);
     abserror:=error;
     if error <> 0 then begin
        beep;
        write('Drive  ',chr($41+drive),':   Cluster',startcluster);
        write(' Error ');puthex(word(error));
        writeln;
     end
     else time2stop:=is_dir(buffy);
  until   time2stop or (startcluster > maxalloc) ;
  if startcluster > maxalloc then cluster_scandir:= 65000
  else cluster_scandir:= startcluster;
end;  (* clusterscandir *)


procedure goexamine;
{ display the cluster sector  by cluster in ascii and hex }
label  1120;
var ch : char;
    response : boolean;
    answer : string[20];
    code   : integer;
    allocblk : longint;
    issector : boolean;
    drive,i,sector,ssector, thiscluster : word;
begin
   drive:= getdrive;
 repeat
   issector:=true; { by sectors }
   write('Cluster number ? ' );
   readln(answer);
   val(answer,thiscluster,code);
 until (code=0) or (upcase(answer[1])='X');
 if upcase(answer[1])='X' then goto 1120;
 logon:=false;
 if thiscluster = 0 then sector := 1
 else if thiscluster = 1 then sector:= firstdir
 else sector:= (thiscluster -2)* sectorcluster + cluster2;
 repeat
   if  not getsector(drive,sector,sector) then beep;
   writeln;
   thiscluster:= (sector -cluster2)  div sectorcluster + 2;
   write('Cluster   ',thiscluster,'   Sector ', sector,'  ');
   puthex(sector);writeln('H  of drive ',
   chr($41+drive),':');
   writeln;
   page;
   writeln;
   writeln('Type SPACE to continue, - to reverse, / to interpret as directory');
   writeln('S to scan for directory , or <CR> to return to menu.');
   ch:=readkey;
   case ch of
      ' ' : sector:=sector+1;
      '-' : sector:=sector-1;
      '/' : begin
              showdir;
	      sector:= sector+1;
              pressspace;
            end;
      'S','s' : sector:=scandir(sector);
   end
 until ch = #$0d;
1120:
end; { examine }

procedure fillnulls;
{ wipe out a sector }
label 1119;
var code : integer;
    answer : mystring;
    i,drive : word;
    x :  integer;
    count : word;
begin
 count:=1;
 initbuffer;
 drive:=getdrive;
 repeat
   write('Absolute sector number? ' );
   readln(answer);
   val(answer,i,code);
 until (code=0) or (upcase(answer[1]) in ['X','Z','Q']);
 if upcase(answer[1]) in ['X','Z','Q'] then exit;
       x:=abswrite(drive, i, count, addr(sectorbuffer[0]) );
       if x <> 0 then begin
	  write('Drive  ',chr($41+drive),':   Sector ',i);
          write(' Error code  ');puthex(word(x)); writeln;
       end;
   1119:
end;

procedure stripjunk( var s : mystring );
{ removes noninteger, - from a string }
var
  t : mystring;
  i : integer;
begin
   t:='';
   for i:=1 to length(s) do begin
      if s[i] in ['0'..'9','-','X','Q','Z','z','x','q',^D,^Z ] then t:=t+s[i];
   end;
   s:=t;
end; {stripjunk}

procedure collectsectors; { collect sectors into a disk file }
label collectexit;
var idata,itarget,i,x,code,myeof : integer;
    sdisk : string[10];
    answer,sdata, starget, ans1,ans2 : mystring;
    keyboard : boolean;
    fdata : text; { read in ascii numbers }
    ftarget : file; { untyped for blockwrite }
    exitcode : char;
    dashpos,i1,i2,code1,code2 : integer;
    drive, count : word;

begin  { collect sectors }
   keyboard:=false;
   count:=1;
   clrscr;writeln;writeln;writeln;writeln;
   writeln('This collects a list of absolute sectors into a disk file.');
   writeln('It is not recommended that the file be saved to the disk');
   writeln('being read.');
   if not havelogged  then begin beep;exit;end;
   drive:=getdrive;
   write('File with disk sectors? '); readln(sdata);
   assign(fdata,sdata);
   {$I-}
   reset(fdata);  idata:=ioresult;
   {$I+}
   if  idata <> 0 then begin
         writeln('Sector list from ', sdata,' not found, ');
         writeln('Enter data on keyboard.');
         keyboard:=true;
   end;
   write('Name of target file? ');readln(starget);
   assign(ftarget,starget);
   {$I-}
   rewrite(ftarget);
   itarget:=ioresult;
   {$I+}
 while not eof(fdata) do begin  { until get a stop character }

    repeat     { until get a good entry }
        if keyboard then write('Absolute sector number? ' );
        if keyboard then readln(answer)
        else begin
            {$I-}
            readln(fdata,answer);
            myeof:=ioresult;
            {$I+}
            if myeof <> 0 then begin exitcode:='X' ; goto collectexit;end;
        end;
        stripjunk(answer); { clean it up }
        dashpos:=pos('-',answer);
        if dashpos > 0 then begin
            ans1:=copy(answer,1,dashpos-1);
            ans2:=copy(answer,dashpos+1,255);
        end else begin
                   ans1:=answer ;
                   ans2:='';
        end;
        gotoxy(1,24);clreol;
        write('Here was the input:  ',ans1,'    ',ans2);
        delay(1000);
        val(ans1,i1,code1);
        val(ans2,i2,code2);
        if code2 <> 0 then begin
            writeln;
            writeln('Illegal second sector number: ',answer, ' .');
            delay(1000);
            i2:=0;
        end;
        if code1 <> 0 then begin
            writeln;
            writeln('Illegal first sector number: ',answer, ' .');
            i1:=0;   delay(1000);
        end;
        exitcode:=upcase(ans1[1]);
     until ( (code1=0) or (exitcode in ['X','Z','Q',^Z,^X,^D]));
       { got good input }
       if exitcode in ['X','Z','Q',^Z,^X,^D] then goto collectexit;
       { copy sectors i1 to i2 over to a disk file }
       drive:= drivenumber and $00ff;

       for i:=i1 to max(i1,i2)  do begin
             x:=absread(drivenumber, i1, count, addr(sectorbuffer[0]));
             abserror:=x;
             gotoxy(1,25);
             clreol;
             write('Reading Sector ',i:5);
           {  delay(1000); }
             if (x  <> 0  ) then begin
                 write('Drive  ',chr($41+drivenumber),':   Sector ',i);
                 write(' Error code  ');puthex(word(x));writeln;
             end;
             blockwrite(ftarget,sectorbuffer[0],sectorcluster);
       end; { for i }
   end; { while not eof(fdata) }
collectexit:
   { close up and go home }
   if not keyboard then close(fdata);
   close(ftarget);
end; { collectsectors }



procedure savefat;
var
    errtarget, error : integer;
    starget : mystring;
    ftarget : file; { untyped for blockwrite }
    ii, drive, count : word;

begin  { savefat }
   count:=1;
   clrscr;
   writeln;
   writeln;
   writeln('This saves the first FAT table as a disk file.');
   writeln('It is not recommended that the file be saved to the disk');
   writeln('being read.');
   if not havelogged then begin
     beep;
     exit;
   end;

   drive:=getdrive;
   write('File to save FAT table? ');
   readln(starget);
   assign(ftarget,starget);
   {$I-}
   rewrite(ftarget);
   errtarget:=ioresult;
   {$I+}
   if errtarget <> 0 then begin
      beep;
      writeln('Can''t open ',starget);
      writeln('Try again.');
      exit;
   end;

   for ii:= numresv_sectors to (numresv_sectors + (fatsectors -1))
     do begin
         error:=absread(drivenumber, ii, count, addr(sectorbuffer[0]));
         abserror:=error;
         gotoxy(1,25);
         clreol;
         write('Reading Sector ',ii:5);
         delay(300);
         if (error  <> 0  ) then begin
              write('Drive  ',chr($41+drivenumber),':   Sector ',ii);
              write(' Error code  ');
              puthex(word(error));
              writeln;
          end;  (* if *)
          blockwrite(ftarget,sectorbuffer[0],4);
   end; { for ii }
   { close up and go home }
   close(ftarget);
end; { savefat }

(* next procedure for disk crash recover analysis *)
(* gives output in form
    sector xx cluster yy
    dump of directory contents  ascii or hex
*)

procedure savedirs;  (* scan for directory entries *)
var
    short : boolean;
    namedirs : mystring;
    fdirs : text;
    sector,cluster, limit : word;
    drive : word;
    errtarget : integer;
    buffy : bufptr;
begin  { savedir }
   buffy:= addr(sectorbuffer[0]);
   clrscr;
   writeln;
   writeln;
   writeln('This scans the entire disk for stray directory entries.');
   writeln('It is not recommended that the file be saved to the disk');
   writeln('being read.');
   if not havelogged then begin
     beep;
     exit;
   end;

   drive:=getdrive;
   quietgetbpb(drive);

   write('File to save directories? ');
   readln(namedirs);
   assign(fdirs,namedirs);
   {$I-}
   rewrite(fdirs);
   errtarget:=ioresult;
   {$I+}
   if errtarget <> 0 then begin
      beep;
      writeln('Can''t open ',namedirs);
      writeln('Try again.');
      exit;
   end;
   writeln;
   write('Last cluster to scan? '); readln(limit);
   cluster:=0;
   repeat
     cluster:= cluster_scandir(cluster);   (* get next cluster which is dir *)
     if cluster > 1 then short:=true else short:= false;
     sector:=xlatecluster(cluster);
     if absioerr = 0 then
     if sector < maxsectors then begin
       write(fdirs,'Found dir sector at ',sector:6,' ');
       fputhex(fdirs,sector);
       write(fdirs,'H, or cluster ', cluster:6,' ');
       fputhex(fdirs,cluster);
       writeln(fdirs,'H.');
       cluster_fshowdir(fdirs,buffy,limit, short);
     end;
     until sector > maxsectors;
   { close up and go home }
   close(fdirs);
end; { savedirs }



function menu : char;
var  c:char;
begin
  writeln('F...save fat table to disk file');
  writeln;
  writeln('L...log in MSDOS disk.');
  writeln;
  writeln('P....show disk parameters');
  writeln;
  writeln('E....examine a sector');
(* writeln;
  writeln('F....fill a sector with zeroes');
  *)
  writeln;
  writeln('G....go to cluster');
  writeln;
  writeln('R....check a group of sectors for errors');
  writeln;
  writeln('S...scan for directory clusters ');
  writeln;
  writeln('C....collect a group of sectors into a disk file.');
  writeln;
  writeln('Q....return to DOS');
  writeln;
  write('Your choice ?  ');
  c:=readkey;
  writeln(c);
  menu:=upcase(c);
end; { menu }

procedure initialize;
begin
  canwrite:=false;
  havelogged:=false;
  abserror:=0;
  initbuffer;
end;

procedure logdrive;
var ch : char;
    drive : integer;
begin
  havelogged:=false;
  repeat
      write('Which drive? ');
      readln(drivename);
      ch:=upcase(drivename[1]);
      drive:=ord(ch) - ord('A');
  until (ch in ['A'..'P']) and (drive < drivemax);
  if  drive >= 0 then begin
      quietgetbpb(drive);
      havelogged :=true;
      drivenumber:=drive;
  end else begin
      havelogged:=false;
      drivenumber:= $ff;
  end;
 end; { logdrive }


begin  { main }
  logo;
  initialize;
  while true do begin
       repeat
         writeln;
         c:=menu;
         c:=upcase(c);
       until c in ['L','F','C','P','E','S','Z','G','X','Q','R',#$1a];
       case c of
	  'L' : logdrive;
	  'P' : if havelogged then getbpb;
	  'R' : if havelogged then checksector;
	  'E' : if havelogged then examine;
	  'G' : if havelogged then goexamine;
	  'C' : if havelogged then collectsectors;
          'F' : savefat;
          'S' : savedirs;
          'X','Q','R',#$1A,'Z' : halt;
          else begin end; { do nothing for default }
       end;{ case }
  end; { while }
end.