{$M 4096,0,65535}

{
Written by Trixter / Hornet (Jim Leonard, trixter@hornet.org)
for the defunct Flopper Project (Floppy disk boot emulator).
Dumps a floppy diskette to an image file.

If dumping sector by sector, unreadable sectors are filled with "!!!"s.
}

Program disk2img;

uses
  flprglob,   {Flopper utils unit; global variables}
  flprdisk,   {Flopper utils unit; low-level disk utilities}
  flprsprt,   {Flopper utils unit; additional support routines}
  support,    {misc support routines}
  TFastWrite, {ludicrously fast textmode writing routines}
  cmdlin;     {external "getopt"-like library by Jim Walsh, CIS:72571,173}

const
{  displayhex:boolean=true;}
  badsec9s:byte=0;  {quick'n'dirty format checking}
  badhead1s:word=0; {quick'n'dirty format checking}
  totalsectors:word=0;
  starttick:longint=0;
  screencolumns=80;
  Recover:boolean=false;
  Query:boolean=false;
  TrackDump:boolean=false;
  RenameExt:boolean=false;

const
  tickHz=$1234de/65536;

var
  filename:string;


{------Main program functions------------------------------------------------}

Function DriveStatusString(status:byte):string;
begin
  case status of
    $00:DriveStatusString:='00: status OK';
    $01:DriveStatusString:='01: invalid function in AH or invalid parameter';
    $02:DriveStatusString:='02: address mark not found';
    $03:DriveStatusString:='03: disk write-protected';
    $04:DriveStatusString:='04: sector not found';
    $06:DriveStatusString:='06: floppy disk removed';
    $08:DriveStatusString:='08: DMA overrun';
    $09:DriveStatusString:='09: attempted DMA across 64K boundary';
    $0C:DriveStatusString:='0c: bad media type or invalid media';
    $10:DriveStatusString:='10: uncorrectable CRC error';
    $20:DriveStatusString:='20: controller failed';
    $40:DriveStatusString:='40: seek failed';
    $80:DriveStatusString:='80: timeout (disk not ready)';
    { hard-drive and special codes, for anyone interested }
    { $05:writeln('reset failed (hard disk)');}
    { $07:writeln('drive parameter activity failed (hard disk)');}
    { $0A:writeln('bad sector detected (hard disk)');}
    { $0B:writeln('bad track detected (hard disk)');}
    { $0D:writeln('invalid number of sectors on format (PS/2 hard disk)');}
    { $0E:writeln('control data address mark detected (hard disk)');}
    { $0F:writeln('DMA arbitration level out of range (hard disk)');}
    { $10:writeln('uncorrectable CRC or ECC data error!');}
    { $11:writeln('data ECC corrected (hard disk)');}
    { $31:writeln('no media in drive (IBM/MS INT 13 extensions)');}
    { $32:writeln('incorrect drive type stored in CMOS (Compaq)');}
    { $AA:writeln('drive not ready (hard disk)');}
    { $B0:writeln('volume not locked in drive (INT 13 extensions)');}
    { $B1:writeln('volume locked in drive (INT 13 extensions)');}
    { $B2:writeln('volume not removable (INT 13 extensions)');}
    { $B3:writeln('volume in use (INT 13 extensions)');}
    { $B4:writeln('lock count exceeded (INT 13 extensions)');}
    { $B5:writeln('valid eject request failed (INT 13 extensions)');}
    { $BB:writeln('undefined error (hard disk)');}
    { $CC:writeln('write fault (hard disk)');}
    { $E0:writeln('status register error (hard disk)');}
    { $FF:writeln('sense operation failed (hard disk)');}
  else
    DriveStatusString:='unknown error';
  end;
end;

Procedure DumpInit;

const
  defaultName='output.img';

  Procedure printhelp;
  begin
    writeln('Usage is:  "DISK2IMG d: filename.ext [options]", where "d:" is drive letter.');
    writeln('Optional switches:');
    writeln;
    writeln('Option  Description                                  Default');
{    writeln('~~~~~~  ~~~~~~~~~~~                                  ~~~~~~~');}
{    writeln('  /N    do Not build the sector display              ',not displayhex);}
    writeln('  /Txx  number of Tracks                             /t',numtracks);
    writeln('  /Sxx  number of Sectors per track                  /s',numsectors);
    writeln('  /Hx   number of Heads                              /h',numheads);
    writeln('  /Zx   sector siZe                                  /z',sectorsize);
    writeln('  /R    Recover mode (ignore errors and retry)       ',Recover);
    writeln('  /E    Rename file extension to match image size    ',renameExt);
    writeln('  /Q    Query boot sector to get disk parameters     ',Query);
    writeln('  /F    Fast mode (track-at-once, NO ERROR CHECKING) ',TrackDump);
    writeln('  /Dx   optional way to specify drive to work on     /d',upcase(chr(65+CurDrive)));
    writeln;
    writeln('Default settings reflect a ',numtracks*numsectors,'K diskette in drive ',upcase(chr(65+CurDrive)),':');
    writeln('If no filename is specified, the name "'+defaultname+'" will be used.');
    writeln;
    writeln('Examples:');
    writeln('DISK2IMG a: mygame.img /f       dumps disk in A: to "mygame.img" in "fast" mode');
    writeln('DISK2IMG b: bootdisk.img /q /e    query disk geometry and rewrite .ext to match');
    halt(1);
  end;

  Procedure GetOptions;
  var
    foos:string;
    fooc:char;

  begin
    {help}
    if is_param('?') then printhelp;

    {new filename?}
    filename:=defaultName;
    if non_flag_count>0 then begin
      filename:=non_flag_param(1);
      {if filename is "A:", "B:" etc. then pick the other string as filename}
      if filename[2]=':'
        then if non_flag_count>1
          then filename:=non_flag_param(2)
          else filename:=defaultName;
    end;

    {drive to work on}
    if is_param('d') then begin
      foos:=param_text('d');
      CurDrive:=ord(upcase(foos[1]))-65;
    end;
    {Also handle if first string is less than 3 chars since that is a drive}
    if (non_flag_count<>0) and (length(non_flag_param(1))<3) then begin
      foos:=non_flag_param(1);
      CurDrive:=ord(upcase(foos[1]))-65;
    end;

    {hex display}
    {if getopt('n')<>#0 then displayhex:=false;}

    {number of tracks}
    if is_param('t') then numtracks:=param_int('t');

    {number of sectors per track}
    if is_param('s') then numsectors:=param_int('s');

    {number of heads}
    if is_param('h') then numheads:=param_int('h');

    {sector size}
    if is_param('z') then sectorsize:=param_int('z');

    {enable blatant disregard for errors}
    if is_param('r') then Recover:=true;

    {query drive for params.}
    if is_param('q') then Query:=true;

    {Rename filename extension to match size of image?}
    if is_param('e') then renameExt:=true;

    {query for fast mode which reads entire tracks but has less error handling}
    if is_param('f') then TrackDump:=true;
  end;

  Procedure SetupVars;
  var
    status:byte;
    tmpe:string[12];
    dsp:^boot_structure;
  begin
    {this should be the ONLY time we reset the drive subsystem}
    status:=ResetDrive(CurDrive);
    if status<>0
      then fatalerror(1,'"'+DriveStatusString(status)+'" when resetting drive subsystem');

    if Query then begin
      getmem(sectorbuffer,2048);
      status:=ReadSectors(CurDrive, 0, 0, 1, 1, sectorbuffer);
      if status<>1 {should get number of sectors read as return value}
        then fatalerror(2,'Nothing read; "'+DriveStatusString(GetDriveStatus(curdrive))+'" when trying to query boot sector');
      dsp:=sectorbuffer;
      if (dsp^.sectors_per_track = 0)
      or (dsp^.sectors_per_track > 18)
      or (dsp^.number_of_heads = 0)
      or (dsp^.number_of_heads > 2)
        then fatalerror(3,'Not a DOS-formatted diskette; re-run without /Q');
      sectorsize:=dsp^.bytes_per_sector;
      numsectors:=dsp^.sectors_per_track;
      numheads:=dsp^.number_of_heads;
      numtracks:=dsp^.total_sectors div numsectors div numheads;
      freemem(sectorbuffer,2048);
    end;

    tracksize:=sectorsize*numsectors*numheads;
    totalsectors:=numtracks*numsectors*numheads;
    totaltrackreads:=numtracks*numheads;
    getmem(trackbuffer,tracksize);
    If trackdump
      then sectorbuffer:=trackbuffer
      else getmem(sectorbuffer,sectorsize);

    if renameExt then begin
      status:=pos('.',filename); {grab location of period}
      if status<>0 then begin
        delete(filename,status+1,length(filename)-status);
        tmpe:=inttostr(((numtracks*numsectors) div 2)*numheads); {make extension "360" or "1440" etc.}
        if length(tmpe) > 3 then byte(tmpe[0]):=3; {truncate extension if necessary}
        filename:=filename+tmpe;
      end;
    end;
  end;

  Procedure PrintWelcome;
  var
    foo:byte;
  begin
    write('ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
    PrintHeader('DISK2IMG','Dumps a diskette to a raw image file','0.9',20130627);
  end;

begin
  filename:=defaultname;
  PrintWelcome;
  GetOptions;
  SetupVars;
  {Set up fast textmode writing}
  tfastinit(80,25);
  tfastclrscr(vidp,$00,0);
  tfastsetcolor(normcolor);
  tfastsetdest(vidp);
  tfastsetpos(0,0);
end;

Procedure DumpDo;
const
  curstatus:byte=0;

var
  sectors,heads,tracks:byte;
  foop:^byte;
  f:file;
  status:byte;

  Procedure DisplaySector;assembler;
  asm
    push ds
    les  di,vidp
    add  di,(ScreenColumns * 2)-(secdisplaylinelength * 2) {location on screen to start}
    mov  ax,sectorsize
    mov  dl,secdisplaylinelength
    div  dl {ax contains sectorsize divided by sectordisplay line length which is number of lines to draw (8 usually)}
    mov  bx,ax
    lds  si,sectorbuffer
    cld
    {call m6845_WaitVertRetrace}
    mov  ah,sectcolor {fill ah with char display attribute}
@displayloop:
    mov  cx,(secdisplaylinelength / 16) {unrolled}
@lineloop: {unrolled a little bit}
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    lodsb; stosw
    loop @lineloop
    add  di,(ScreenColumns * 2)-(secdisplaylinelength * 2) {skip to next line}
    dec  bx {dec line count}
    jnz  @displayloop {if not done, do another line}
    pop  ds
  end;

  Procedure DisplayStatus(s:string);
  const
    statusline=18;
    blanks:string='                                                                               ';
  begin
    {clear line}
    {fillchar(ptr(seg(vidp^),(statusline-1) * ScreenColumns * 2)^,ScreenColumns *2,0);}
    tfastwritexy(@blanks,vidp,0,statusline,emphcolor);
    tfastwritexy(@s,vidp,0,statusline,emphcolor);
  end;

  Procedure DisplayDriveStatus;

    function secstomins(secs:real):string;
    var
      min,sec:string;
    begin
      min:=inttostr(round(secs) div 60);
      sec:=inttostr(round(secs) mod 60);
      if sec[0]=#1
        then secstomins:=min+':0'+sec
        else secstomins:=min+':'+sec;
    end;

  var
    percent:real;
    totalsecs:real;
    secselapsed:real;
    secsremaining:real;
    temps:string;

  begin
    tfastsetpos(0,0);
    tfastwriteln('   Drive: '+chr(65+CurDrive)+':');
    tfastwriteln('   Track: '+inttostr(tracks)+' ');
    tfastwriteln('    Head: '+inttostr(heads)+' ');
    if not trackdump
      then tfastwriteln('  Sector: '+inttostr(sectors)+' ');
    tfastwriteln('Sectsize: '+inttostr(sectorsize));

    secselapsed:=(TicksSinceMidnight-starttick)/tickHZ;
    if trackdump
      then percent:=(trackreadcount/totaltrackreads) * 100
      else percent:=(sectorcount/totalsectors) * 100;
    if (percent<>0)
      then totalsecs:=((TicksSinceMidnight-starttick)/tickHZ) / percent * 100
      else totalsecs:=1;
    secsremaining:=totalsecs-secselapsed;

    {writeln('Sec.elap.: ',secselapsed:2:0);}
    {writeln(' Complete: ',percent:2:0,'%');}
    Str(percent:2:1,temps);
    temps:=temps+'%';
    tfastwriteln('Complete: '+temps);
    {writeln(totalsecs:3:0,' total time');}

    {gotoxy(1,(sectorsize div secdisplaylinelength)+1);
    writeln('Time remaining: ',secstomins(secsremaining),'  ');}
    temps:='Time remaining: '+secstomins(secsremaining)+'  ';
    tfastwritexy(@temps,vidp,0,(sectorsize div secdisplaylinelength)+1,normcolor);

    curstatus:=GetDriveStatus(CurDrive);
    temps:='Last status code: '+DriveStatusString(curstatus);
    DisplayStatus(temps);
    {writeln(#32:79);}
  end;

begin
  {get the output file ready}
  assign(f,filename);
  rewrite(f,1);
  {if IOResult<>0 then FatalError(4,'IOResult '+inttostr(IOResult)+' during file handling.');}
  {initialize the floppy controller subsystem}
  {read dummy sector three times in a row to force drive to spin up}
  DisplayStatus('Forcing motor to spin...');
  for sectors:=0 to 2 do begin
    DisplayStatus('Reading sector #0...');
    {read only first sector since that is the only sector guaranteed to be readable}
    curstatus:=ReadSectors(CurDrive,0,0,1,1,sectorbuffer);
    if curstatus<>1 {no sectors read} then begin
      DisplayStatus('Wrong number of sectors read; resetting drive...');
      resetdrive(CurDrive);
    end else break;
  end;

  {if we never read anything successfully, abort}
  if curstatus<>1 then fatalerror(10,'All sample reads returned errors; reboot to reset the BIOS disk subsystem.');

  DisplayStatus('Checking drive motor...');
  if (DriveMotorStatus and $F = 0) and not recover then fatalerror(5,'Disk drive did not spin up!');

  starttick:=TicksSinceMidnight;
  for tracks:=0 to numtracks-1 do begin
    {reset offset}
    foop:=trackbuffer;
    for heads:=0 to numheads-1 do
      {if user requests full track dumping, let them and perform no error checking}
      if trackdump then begin
        sectorbuffer:=foop;
        sectors:=1; {we're reading an entire track so start at sector 1}
        curstatus:=ReadSectors(CurDrive,heads,tracks,sectors,numsectors,foop);
        DisplaySector;
        DisplayDriveStatus;
        {increment dest. pointer if we have more heads to read}
        inc(longint(foop),tracksize div numheads);
        inc(trackreadcount);

        if keypressed then begin
          close(f);
          fatalerror(0,'User aborted');
        end;
      end else begin
        for sectors:=1 to numsectors do begin
          {fill sector buffer with !'s}
          fillchar(sectorbuffer^,sectorsize,'!');
          {read a sector into the sector buffer}
          curstatus:=ReadSectors(CurDrive,heads,tracks,sectors,1,sectorbuffer);
          if (Recover) and (curstatus<>1)
            then while curstatus<>0 do begin
              DisplayStatus('(Recover) Drive status: '+DriveStatusString(curstatus)+'  Re-Reading Sector...');
              fillchar(sectorbuffer^,sectorsize,'!');
              curstatus:=ReadSectors(CurDrive,heads,tracks,sectors,1,sectorbuffer);
              {if user says screw this, then move on}
              if keypressed then begin
                while keypressed do readkeychar;
                DisplayStatus('(Recover) Aborting this sector...');
                break;
              end;
            end;
          {if curstatus <> 1 sector read, then we have an error and we should handle it}
          if curstatus<>1 then begin
            {record some stuff for quick'n'dirty error checking}
            if (sectors=9) then inc(badsec9s);
            if (heads=(numheads-1)) then inc(badhead1s);
          end;
          {display the sector on the screen for eyecandy purposes}
          {if displayhex then} DisplaySector;
          {display drive status}
          DisplayDriveStatus;
          {move the sector data into the track buffer...}
          move(sectorbuffer^,foop^,sectorsize);
          {...and increment the track buffer offset for next time}
          inc(longint(foop),sectorsize);
          inc(sectorcount);
          {check for keypress and exit this procedure if a key is hit}
          if keypressed then begin
            close(f);
            fatalerror(0,'User aborted');
          end;
        end;
      end; {if trackdump}
    {dump 'em}
    blockwrite(f,trackbuffer^,TrackSize);
  end;
  close(f);
end;

Procedure DumpDone;

  Procedure FreeVars;
  begin
    freemem(trackbuffer,TrackSize);
    if not trackdump then freemem(sectorbuffer,sectorsize);
  end;

  Procedure CleanUp;

    procedure ReportError(actualtype,newswitch:string);
    begin
      writeln('The disk you just dumped appears to ',actualtype,'.');
      writeln('You should re-dump it with the "-',newswitch,'" command-line switch.');
      writeln;
    end;

  begin
    tfastclrscr(vidp,$07,0); PositionCursor(0,23); writeln('Done.');
    {any "AI" to report?}
    {if number of bad sector 9's == the number of tracks*heads, then
     every single sector 9 didn't read--which means it's probably an 8-sector
     disk.  Warn user appropriately.}
    if badsec9s=(numtracks*numheads)
      then reporterror('have 8 sectors per track','s8');
    {if number of bad sectors on the second side == everything then
     every single sector on the second side didn't read--which means it's probably a
     single-sided disk.  Warn user appropriately.}
    if badhead1s=(numtracks*numsectors)
      then reporterror('be a single-sided disk','h1');
  end;

begin
  FreeVars;
  CleanUp;
end;

begin
  DumpInit;
  DumpDo;
  DumpDone;
end.
