#!/usr/bin/perl -w

use strict;

binmode STDIN;
#binmode STDOUT;

my $use_fat = 0;
my $emit_rootdir = 0;
my $emit_fat32;
my $emit_prefat32;
my $root;
my $infofile;
my $offset = 0;

eval {
  require Getopt::Long;
  Getopt::Long::GetOptions(
    'fat=i' => \$use_fat,
    'offset=i' => \$offset,
    'extract=s' => \$root,
    'rootdir!' => \$emit_rootdir,
    'emit_fat32=s' => \$emit_fat32,
    'emit_prefat32=s' => \$emit_prefat32,
    'infofile=s' => \$infofile,
  );
} or warn "getopt failed: $@";

@ARGV == 0 or die "usage: $0 [-fat=N -offset=BYTES -extract=ROOTDIR -emit_fat32 -rootdir -infofile=OUTPUT_FILE]";
#open DEBUG, "> $root/.DEBUG" or die "debug open: $!";
open DEBUG, ">$infofile" or die "debug open: $!" if defined $infofile;
binmode DEBUG if defined $infofile;

sub really_read ($) {
  my $bytes = shift;
  return '' unless $bytes;
  my $read = sysread STDIN, (my $in), $bytes;
  die "read $read bytes, expecting $bytes" unless $read == $bytes;
  return $in;
}

sub decode_fields ($$) {
  my ($fields2, $in) = (shift,shift);
  my $lastfield = @$fields2/2 - 1;
  my $extract = join ' ', @$fields2[map 2*$_ + 1, 0 .. $lastfield];
  my @values = unpack $extract, $in;
  map( ($$fields2[2*$_] => $values[$_]),  0 .. $lastfield);
}

if (defined $emit_fat32 and -e $emit_fat32) {
  warn "Unlinking '$emit_fat32'...\n";
  unlink $emit_fat32 or die "unlink '$emit_fat32': $!";
}
really_read $offset if $offset;
my $bootsect = really_read 512;

# validation pattern - to guard against booting an MBR when it has never
# been set up, the BIOS checks for a special pattern (0x55 0xAA) in the
# last word of the MBR (immediately following the partition table).
# Any valid MBR contain this pattern.

my $offset_sectors = $offset/512;
if (!$offset and "\x55\xAA" eq substr $bootsect, -2) {
  # Up to offset 1BEh the MBR consists purely of machine code and data (strings
  # etc.). At offset 1BEh the first primary partition is defined, this takes 16
  # bytes, after which the second primary partition is defined, followed by
  # the third and fourth, the data structures are the same.

  my @parts = unpack 'x446 a16 a16 a16 a16', $bootsect;

  # 00h 1 Set to 80h if this partition is active.
  # 01h 1 Partition's starting head.
  # 02h 2 Partition's starting [48]sector and track.
  # 04h 1 Partition's [49]ID number.
  # 05h 1 Partition's ending head.
  # 06h 2 Partition's ending [50]sector and track.
  # 08h 4 Starting LBA.
  # 0Ch 4 Partition's length in sectors.


  # Format of sector and track information.Bits 15-6 Bits 5-0
  #                                          Track    Sector
  # ID numbers:
  # 0Bh Win95 OSR2+ FAT32 (512MB-2TB)			(primary?)
  # 0Ch Win95 OSR2+ FAT32 (512MB-2TB LBA)			(extended?)
  my @part = (	# code	=> 'A446',
                  is_active	=> 'C',
                  start_head	=> 'C',
                  start_sec_track	=> 'v',
                  type		=> 'C',
                  end_head	=> 'C',
                  end_sec_track	=> 'v',
                  start_lba	=> 'V',
                  sectors		=> 'V',
      );

  my @part_value = map { {decode_fields \@part, $_} } @parts;
  for my $p (@part_value) {
    $p->{start_sec}   = $p->{start_sec_track} & 0x3f;
    $p->{start_track} = $p->{start_sec_track} >> 6;
    $p->{end_sec}     = $p->{end_sec_track} & 0x3f;
    $p->{end_track}   = $p->{end_sec_track} >> 6;
  }
  if (defined $infofile) {
    my $n;
    for my $p (@part_value) {
      $n++;
      print DEBUG "  Part $n\n";
      print DEBUG "$_\t=> $p->{$_}\n" for sort keys %$p;
    }
  }

  $offset_sectors = $part_value[0]{start_lba};
  die "The first partition is not defined" unless $part_value[0]{type};
  die "start_lba value is 0" unless $offset_sectors;
  if (defined $emit_fat32) {
    substr($bootsect, 446 + 4, 1) = chr 0x0B;	# Win95 OSR2+ FAT32 (512MB-2TB) (primary?)
    die "Need emit_prefat32 defined too in presence of partition table"
      unless defined $emit_prefat32;
    open F32, "> $emit_prefat32" or die "Error opening `$emit_prefat32' for write: $!";
    binmode F32;
    syswrite F32, $bootsect;
  }
  if ($offset_sectors > 1) {
    my $in = really_read 512*($offset_sectors - 1);
    syswrite F32, $in if defined $emit_fat32;
  }
  close F32 or die "Error closing `$emit_prefat32' for write: $!"
    if defined $emit_fat32;
  $bootsect = really_read 512;
}

# FAT12/FAT16 Boot Sector/Boot Record Layout.

#      The data contained in the boot sector after the OEM name string is
#                referred to as the BIOS parameter block or BPB.
# Offset Length                              Field
#  00h        3               Machine code for jump over the data.
#  03h        8        OEM name string (of OS which formatted the disk).
#  0Bh        2   Bytes per sector, nearly always 512 but can be 1024,2048 or
#                                            4096.
#  0Dh        1 Sectors per cluster, valid number are: 1,2,4,8,16,32,64 and 128,
#                     but a cluster size larger than 32K should not occur.
#  0Eh        2     Reserved sectors (number of sectors before the first FAT
#                            including the boot sector), usually 1.
#  10h        1                Number of FAT's (nearly always 2).
#  11h        2            Maximum number of root directory entries.
#  13h        2  Total number of sectors (for small disks only, if the disk is
#                  too big this is set to 0 and offset 20h is used instead).
#  15h        1  Media descriptor byte, pretty meaningless now (see below).
#  16h        2                         Sectors per FAT.
#  18h        2                        Sectors per track.
#  1Ah        2                   Total number of heads/sides.
#  1Ch        4   Number of hidden sectors (those preceding the boot sector).
#  20h        4             Total number of sectors for large disks.
#  24h       26       Either extended BPB (see below) or machine code.
#  3Eh      448                          Machine code.
#  1FEh       2                      Boot Signature AA55h.

my @boot = (	jump	=> 'A3',
		oem	=> 'A8',
		sector_size	=> 'v',
		sectors_in_cluster	=> 'C',
		fat_table_off	=> 'v',
		num_fat_tables	=> 'C',
		root_dir_entries	=> 'v',
		total_sectors1	=> 'v',
		media_type	=> 'C',
		sectors_per_fat	=> 'v',
		sectors_per_track	=> 'v',
		heads	=> 'v',
		hidden_sectors	=> 'V',
		total_sectors2	=> 'V',
		extended_bpb	=> 'a26',
		machine_code	=> 'a448',
    );

my %value = decode_fields \@boot, $bootsect;
if (defined $infofile) {
  print DEBUG "$_\t=> $value{$_}\n" for sort keys %value;
}

# FAT12/Fat16 Extended BPB.
#
#     The Extended BIOS parameter block is not present prior to DOS 4.0
#                              formatted disks.
#                                   Offset
#                             Length (in bytes)
#                                   Field
# 24h 1 Physical drive number (BIOS system ie 80h is first HDD, 00h is first FDD).
# 25h 1 Current head (not used for this but WinNT stores two flags here).
# 26h 1 Signature (must be 28h or 29h to be recognised by NT).
# 27h 4 The serial number, the serial number is stored in reverse order
#          and is the hex representation of the bytes stored here.
# 2Bh 11 Volume label.
# 36h 8 File system ID. "FAT12", "FAT16" or "FAT  ".

my @e_boot = (
		drive	=> 'C',
		head	=> 'C',
		signature	=> 'C',
		serial_number	=> 'V',
		label	=> 'A11',
		id	=> 'A8',
    );

my %e_value = decode_fields \@e_boot, $value{extended_bpb};
if (defined $infofile) {
  print DEBUG "$_\t=> $e_value{$_}\n" for sort keys %e_value;
}

my $sectors = $value{total_sectors1} || $value{total_sectors2};
my $pre_sectors = $value{fat_table_off}
  + $value{num_fat_tables} * $value{sectors_per_fat}
  + $value{root_dir_entries} * 0x20 / $value{sector_size};
my $nclusters = ($sectors - $pre_sectors)/$value{sectors_in_cluster} + 2;
warn "this is not fat12" unless $nclusters < 0xff7;

my $e_size = $nclusters * 12/8/$value{sector_size};
die "FAT has $value{sectors_per_fat} sectors: expecting $e_size"
  unless $value{sectors_per_fat} >= $e_size;

my @fat;
if ($emit_rootdir or defined $root) {
  really_read $value{sector_size} * ($value{fat_table_off} - 1);
  my $first_fat;
  my @fats;
  my $n = 0;
  while (++$n <= $value{num_fat_tables}) {
    my $fat = really_read $value{sector_size} * $value{sectors_per_fat};
    $first_fat = $fat if $n == 1;
    warn "FAT$n mismatch" if $n > 1 and $fat ne $first_fat;
    $fats[$n] = $fat;
  }
  die "Have only $value{num_fat_tables} FATs, cannot use $use_fat-th"
    if $use_fat > $value{num_fat_tables};
  $first_fat = $fats[$use_fat] if $use_fat;
  my $bzero = "\0";
  $n = 0;
  while ($n < $nclusters) {
    $first_fat =~ s/^(...)//s or die "too short a FAT";
    my $n32 = unpack 'V', "$1$bzero";
    # warn sprintf "got %#04x", $n32;
    push @fat, ($n32 & 0xfff), ($n32 >> 12);
    $n += 2;
  }

  warn sprintf "Wrong signature %d=%#x, media=%#x in cluster(0)", $fat[0], $fat[0], $value{media_type}
    unless $fat[0] == ($value{media_type} | 0xf00);

  my $fat_eof = $fat[1];
  warn "Wrong signature $fat[1] in cluster(1)"
    unless $fat_eof <= 0xfff and $fat_eof >= 0xff8;

  sub cluster_chain ($) {
    my $last = shift;
    die "problem with last=$last as a cluster leader"
      unless $last >= 2 and $last <= $nclusters;
    my @clusters = ($last);
    while (1) {
      # warn "processing $last";
      my $next = $fat[$last];
      return @clusters if ($next >> 3) == (0xfff >> 3);
      $next = 'undef' unless defined $next;
      warn "problem with last=$last => $next in a cluster chain"
        unless $next >= 2 and $next <= $nclusters;
      push @clusters, $last = $next;
    }
  }
}

# Directory Entry Layout.
#
#    The old style directory entry had 10 reserved bytes starting at 0Ch,
#                            these are now used.
# 00h 8 Filename padded with spaces if required (see above).
# 08h 3 Filename extension padded with spaces if required.
# 0Bh 1 File Attribute Byte.
# 0Ch 10 Reserved or extra data.
# 16h 2 Time of last write to file (last modified or when created).
# 18h 2 Date of last write to file (last modified or when created).
# 1Ah 2 Starting cluster.
# 1Ch 4 File size (set to zero if a directory).
#
#
# Extra data Layout (previously reserved area).
#
#    The old style directory entry had 10 reserved bytes starting at 0Ch,
#     these are now used as follows. Presumably these fields are used if
#                                 non-zero.
#                            Offset Length Field
# 0Ch 1 Reserved for use by Windows NT.
# 0Dh 1 Tenths of a second at time of file creation, 0-199 is valid.
# 0Eh 2 Time when file was created.
# 10h 2 Date when file was created.
# 12h 2 Date when file was last accessed.
# 14h 2 High word of cluster number (always 0 for FAT12 and FAT16).

my @file_f = (	basename	=> 'A8',
		ext	=> 'A3',
		attrib	=> 'C',
		nt_reserved	=> 'C',
		creation_01sec	=> 'C',
		time_create	=> 'v',
		date_create	=> 'v',
		date_access	=> 'v',
		cluster_high	=> 'v',
		time_write	=> 'v',
		date_write	=> 'v',
		cluster_low	=> 'v',
		size	=> 'V',
  );

# Skip volume labels?
sub interpret_directory ($) {
  my $dir = shift;
  my @files;
  while (length $dir) {
    $dir =~ s/^((.).{31})//s or die "short directory!";
    next if 229 == ord $2 or $2 eq "\0";	# deleted or not filled
    my %f = decode_fields \@file_f, $1;
    next if $f{basename} =~ /^\.\.?$/ and $f{ext} eq ''; # . and ..
    # $f{cluster} = $f{cluster_low} + ($f{cluster_high} << 16);
    $f{cluster} = $f{cluster_low};	# cluster_high has EA info?
    my $ext = length $f{ext} ? ".$f{ext}" : '';
    $f{name} = "$f{basename}$ext";
    push @files, \%f;
  }
  @files;
}

sub read_clusters ($$) {
  my ($start, $count) = (shift,shift);
  my $s = $pre_sectors + ($start - 2) * $value{sectors_in_cluster};
  sysseek STDIN, $s * $value{sector_size}, 0;
  really_read $count * $value{sectors_in_cluster} * $value{sector_size};
}

sub read_cluster_chain ($) {
  my @clusters = cluster_chain shift;
  my $out = '';
  while (@clusters) {
    my $start = shift @clusters;
    my $c = 1;
    $c++, shift @clusters while @clusters and $start + $c == $clusters[0];
    $out .= read_clusters($start, $c);
  }
  return $out;
}

sub output_cluster_chain ($$$) {
  # warn "output chain: @_\n";
  my $fh = shift;
  return unless $_[1];			# size
  my @clusters = cluster_chain shift;
  my $len = shift;
  my $cut = @clusters * $value{sector_size} - $len;
  warn "wrong length: $len vs. clusters @clusters"
    unless $cut >= 0 and $cut < $value{sector_size};
  while (@clusters) {
    my $start = shift @clusters;
    my $c = 1;
    $c++, shift @clusters while @clusters and $start + $c == $clusters[0];
    $c-- if not @clusters and $cut;
    print $fh read_clusters($start, $c) if $c;
    next if @clusters or not $cut;
    my $last = read_clusters($start + $c, 1);
    substr($last, -$cut) = '';
    print $fh $last;
  }
}

sub write_file ($$) {
  my ($dir, $f) = (shift, shift);
  return if $f->{attrib} & 0x8		# volume label
    or $f->{name} eq 'EA DATA. SF' or $f->{name} eq 'WP ROOT. SF';
  die "directory as file!" if $f->{attrib} & 0x10;
  my $name = "$dir/$f->{name}";
  open OUT, "> $name" or die "error opening $name for write: $!";
  binmode OUT;
  output_cluster_chain \*OUT, $f->{cluster}, $f->{size};
  close OUT or die "error closing $name for write: $!";
  chmod 0555, $name if $f->{attrib} & 0x1;	# read only
  # unset archive mode?
}

sub write_dir ($$;$);
sub write_dir ($$;$) {
  my ($root, $f, $exists) = (shift, shift, shift);
  mkdir $root, 0777 or die "mkdir $root: $!" unless $exists;
  my @files = interpret_directory $f;
  for my $file (@files) {
    write_dir("$root/$file->{name}", read_cluster_chain $file->{cluster}), next
      if $file->{attrib} & 0x10; # dir
    write_file $root, $file;
  }
}

my $root_dir;
$root_dir = really_read $value{root_dir_entries} * 0x20
  if $emit_rootdir or defined $root;

if ($emit_rootdir) {
  for my $file (interpret_directory $root_dir) {
    my $lab = ($file->{attrib} & 0x8) ? ' label' : '';
    my $dir = ($file->{attrib} & 0x10) ? ' dir' : '';
    print "$file->{name}\t=> size=$file->{size}\tattr=$file->{attrib}$lab\n";
    # write_file $root, $file;
  }
}

if (defined $emit_fat32) {
  die "spaces in file names not supported by f32blank" if $emit_fat32 =~ /\s/;
  my $sz = $sectors + $offset_sectors;
  my $cmd = "f32blank SZ:$sz,ds B:N F:$emit_fat32 H:$value{heads} S:$value{sectors_per_track} SP:$value{hidden_sectors},ds";
  warn "running `$cmd'";
  system $cmd and die "return code $?: $!";
}
write_dir $root, $root_dir, 1 if defined $root;