File Coverage

blib/lib/Sys/Export/VFAT.pm

Criterion	Covered	Total	%
statement	474	536	88.4
branch	137	238	57.5
condition	99	190	52.1
subroutine	42	47	89.3
pod	19	19	100.0
total	771	1030	74.8

package Sys::Export::VFAT;
# ABSTRACT: Write minimal FAT12/16/32 filesystems with control over stored file extents
our $VERSION = '0.005_002'; # TRIAL VERSION

use v5.26;
use warnings;
use experimental qw( signatures );
use Fcntl qw( S_IFDIR S_ISDIR S_ISREG );
use Scalar::Util qw( blessed dualvar refaddr weaken );
use List::Util qw( min max );
use POSIX 'ceil';
use Sys::Export::LogAny '$log';
use Encode qw( encode decode );
use Carp;
our @CARP_NOT= qw( Sys::Export Sys::Export::Unix );
use constant {
   ATTR_READONLY  => dualvar(0x01, 'ATTR_READONLY'),
   ATTR_HIDDEN    => dualvar(0x02, 'ATTR_HIDDEN'),
   ATTR_SYSTEM    => dualvar(0x04, 'ATTR_SYSTEM'),
   ATTR_VOLUME_ID => dualvar(0x08, 'ATTR_VOLUME_ID'),
   ATTR_DIRECTORY => dualvar(0x10, 'ATTR_DIRECTORY'),
   ATTR_ARCHIVE   => dualvar(0x20, 'ATTR_ARCHIVE'),
   ATTR_LONG_NAME => dualvar(0x0F, 'ATTR_LONG_NAME'),
   ATTR_LONG_NAME_MASK => 0x3F,
};
use Exporter 'import';
our @EXPORT_OK= qw( FAT12 FAT16 FAT32 ATTR_READONLY ATTR_HIDDEN ATTR_SYSTEM ATTR_ARCHIVE
  ATTR_VOLUME_ID ATTR_DIRECTORY is_valid_longname is_valid_shortname is_valid_volume_label
  build_shortname remove_invalid_shortname_chars );
use Sys::Export qw( isa_hash isa_array isa_handle isa_int isa_pow2 expand_stat_shorthand write_file_extent );
use Sys::Export::VFAT::Geometry qw( FAT12 FAT16 FAT32 );
require Sys::Export::VFAT::AllocationTable;
require Sys::Export::VFAT::File;
require Sys::Export::VFAT::Directory;


sub new($class, @attrs) {
   my %attrs= @attrs != 1? @attrs
            : isa_hash $attrs[0]? %{$attrs[0]}
            : isa_handle $attrs[0]? ( filehandle => $attrs[0] )
            : ( filename => $attrs[0] );
   my $self= bless {}, $class;
   $self->{root}= $self->_new_dir('/', undef, undef);
   # keep root dir separate from subdirs
   delete $self->{_subdirs}{refaddr $self->{root}};
   # apply other attributes
   $self->$_($attrs{$_}) for keys %attrs;
   $self;
}

# Create dir, and store a strong reference in ->{_subdirs}
sub _new_dir($self, $name, $parent, $file) {
   my $dir= Sys::Export::VFAT::Directory->new(name => $name, parent => $parent, file => $file);
   $self->{_subdirs}{refaddr $dir}= $dir;
   $dir;
}


sub filename { @_ > 1? ($_[0]{filename}= $_[1]) : $_[0]{filename} }
sub filehandle { @_ > 1? ($_[0]{filehandle}= $_[1]) : $_[0]{filehandle} }


sub root($self) { $self->{root} }
sub geometry($self) { $self->{geometry} }
sub allocation_table($self) { $self->{allocation_table} }

sub volume_offset($self, @val) {
   if ($self->{geometry}) {
      croak "Geometry already decided" if @val;
      return $self->{geometry}->volume_offset;
   }
   if (@val) {
      croak "volume_offset must be a multiple of 512" if $val[0] & 511;
      return $self->{volume_offset}= $val[0];
   }
   $self->{volume_offset} // 0
}


sub min_bits($self, @val) {
   if (@val) {
      croak "Geometry already decided" if $self->{geometry};
      $self->{min_bits}= $val[0];
   }
   $self->{min_bits}
}

sub bytes_per_sector($self, @val) {
   if ($self->{geometry}) {
      croak "Geometry already decided" if @val;
      return $self->{geometry}->bytes_per_sector;
   }
   if (@val) {
      croak "bytes_per_sector must be a power of 2" unless isa_pow2 $val[0];
      return $self->{bytes_per_sector}= $val[0];
   }
   $self->{bytes_per_sector} // 512
}

sub sectors_per_cluster($self, @val) {
   if ($self->{geometry}) {
      croak "Geometry already decided" if @val;
      return $self->{geometry}->sectors_per_cluster;
   }
   if (@val) {
      croak "sectors_per_cluster must be a power of 2, and 128 or less" unless isa_pow2 $val[0] && $val[0] <= 128;
      return $self->{sectors_per_cluster}= $val[0];
   }
   $self->{sectors_per_cluster}
}

sub fat_count($self, @val) {
   if ($self->{geometry}) {
      croak "Geometry already decided" if @val;
      return $self->{geometry}->fat_count;
   }
   if (@val) {
      croak "fat_count must be positive" unless isa_int $val[0] && $val[0] > 0;
      return $self->{fat_count}= $val[0];
   }
   $self->{fat_count}
}

sub free_space($self, @val) {
   if (@val) {
      croak "Geometry already decided" if $self->{geometry};
      return $self->{free_space}= $val[0];
   }
   $self->{free_space} // 0
}

sub volume_label($self, @val) {
   if (@val) {
      croak "Invalid volume label '$val[0]'" unless is_valid_volume_label($val[0]);
      return $self->{volume_label}= $val[0];
   }
   $self->{volume_label}
}

# The smallest conceivable address where the data region could start
sub _minimum_offset_to_data {
   state $minimum_offset_to_data= Sys::Export::VFAT::Geometry->new(
      bytes_per_sector => 512,
      sectors_per_cluster => 1,
      fat_count => 1,
      root_dirent_count => 1,
      cluster_count => 1
   )->data_start_offset;
}


sub add($self, $spec) {
   $spec= { expand_stat_shorthand($spec) }
      if isa_array $spec;

   defined $spec->{uname} or defined $spec->{name}
      or croak "Require 'uname' or 'name'";
   defined $spec->{mode} or croak "Require 'mode'";

   # If user supplied uname, use that as a more official source of Unicode
   my $path= $spec->{uname} // decode('UTF-8', $spec->{name}, Encode::FB_CROAK | Encode::LEAVE_SRC);
   $path =~ s,^/,,; # remove leading slash, if any

   my @path= grep length, split '/', $path;
   my $leaf= pop @path;

   # Walk through the tree based on the case-folded path
   my $parent= $self->root;
   for (@path) {
      my $ent= $parent->entry($_);
      if ($ent) {
         croak $ent->name." is not a directory, while attempting to add '$path'"
            unless $ent->{dir};
      } else { # Auto-create directory. Autovivication is indicated by ->{file} = undef
         $ent= $parent->add($_, undef);
         my $name= ($parent == $self->root? '' : $parent->name)."/$_";
         weaken($ent->{dir}= $self->_new_dir($name, $parent, undef));
      }
      $parent= $ent->{dir};
   }

   # did user supply FAT attribute bitmask?
   my $flags= $spec->{FAT_flags} // do {
      # readonly determined by user -write bit of 'mode'
      (!($spec->{mode} & 0400)? ATTR_READONLY : 0)
      # hidden determined by leading '.' in filename
      | (defined $leaf && $leaf =~ /^\./? ATTR_HIDDEN : 0)
   };
   my $file;
   if (S_ISREG($spec->{mode})) {
      my ($size, $offset, $align, $data_ref)
         = @{$spec}{qw( size device_offset device_align data )};
      $data_ref= do { my $x= $data_ref; \$x }
         if defined $data_ref && !ref $data_ref;
      if ($size) {
         # ensure data matches
         croak "File $path has size=$size but lacks 'data' attribute"
            unless defined $data_ref;
         croak "File $path ->{data} length disagrees with ->{size}"
            unless length($$data_ref) == $size;
      } elsif (defined $data_ref) {
         $size //= length($$data_ref);
      }
      # must be a power of 2
      croak "Invalid device_align $align for '$path', must be a power of 2"
         if defined $align && !isa_pow2 $align;
      # Sanity check device_offset before we get too far along
      if (defined $offset) {
         $align //= 512;
         # must fall in the data area
         $offset > $self->volume_offset + _minimum_offset_to_data
         # must be a multiple of at least 512 (probably more)
         && !($offset & ($align-1))
            or croak "Invalid device_offset '$offset' for file '$path'";
      }
      $file= Sys::Export::VFAT::File->new(
         name => "/$path", size => $size, flags => $flags,
         align => $align, device_offset => $offset, data => $data_ref,
         $spec->%{qw( atime btime mtime )},
      );
   } elsif (S_ISDIR($spec->{mode})) {
      $flags |= ATTR_DIRECTORY;
      # If adding this directory overtop a previous auto-vivified directory, the ->{file}
      # will be empty and we can just update it.
      my $cur= $parent->entry($leaf);
      croak "Attempt to add duplicate directory $leaf"
         if $cur && $cur->{file};
      $file= Sys::Export::VFAT::File->new(
         name => "/$path", size => 0, flags => $flags, $spec->%{qw( atime btime mtime )},
      );
      if ($cur) {
         $cur->{file}= $file;
         $cur->{dir}{file}= $file;
         $log->debugf("updated attributes of %s", $path);
         return $cur;
      }
      # otherwise, add this file to a directory entry
   }
   else {
      # TODO: add conditional symlink support via hardlinks
      croak "Can only export files or directories into VFAT"
   }

   # this also checks for name collisions on shortname
   my $ent= $parent->add($leaf, $file, shortname => $spec->{FAT_shortname});
   # If the dirent is a directory, also add a directory object to the dirent
   if ($file->is_dir) {
      # the directory object also gets a reference to its file object.
      weaken($ent->{dir}= $self->_new_dir("/$path", $parent, $file));
   }

   $log->debugf("added %s longname=%s shortname=%s %s",
      $path, $ent->{name}, $ent->{shortname}//'', join(' ',
         !$ent->{file}? ('size=0 (empty file)')
         : $ent->{file}->is_dir? ('DIR')
         : (
            (defined $ent->{file}->size? sprintf("size=0x%X", $ent->{file}->size) : 'size='),
            (defined $ent->{file}->align? sprintf("device_align=0x%X", $ent->{file}->align) : ()),
            (defined $ent->{file}->device_offset? sprintf("device_offset=0x%X", $ent->{file}->device_offset) : ())
         )
      ))
      if $log->is_debug;

   $ent->{file};
}


sub finish($self) {
   my $root= $self->root;
   $log->debug('begin VFAT::finish');
   # Find out the size of every directory, and build ->{_allocs}, ->{_dir_allocs} and ->{_special_allocs}
   $self->_calc_dir_size($_) for $root, values $self->{_subdirs}->%*;
   # calculate what geometry gives us the best size, when rounding each file to that cluster
   # size vs. the size of the FAT it generates
   my ($geom, $alloc)= $self->_optimize_geometry
      or croak join("\n", "No geometry options can meet your device_offset / device_align requests:",
            map "$_: $self->{_optimize_geometry_fail_reason}{$_}",
               sort { $a <=> $b } keys $self->{_optimize_geometry_fail_reason}->%*
         );
   $self->{geometry}= $geom;
   $self->{allocation_table}= $alloc;
   $self->_commit_allocation; # copy cluster IDs into each of the File objects
   # Pack directories now that all file cluster ids are known
   $self->_pack_directory($_) for $root, values $self->{_subdirs}->%*;

   my $fh= $self->filehandle;
   if (!$fh) {
      defined $self->filename or croak "Must set filename or filehandle attributes";
      open $fh, '+>', $self->filename
         or croak "open: $!";
   }
   # check size
   if (-s $fh < $geom->volume_offset + $geom->total_size) {
      $log->debugf('resize output file to %s', $geom->volume_offset + $geom->total_size);
      truncate($fh, $geom->volume_offset + $geom->total_size)
         or croak "truncate: $!";
   }
   $self->_write_filesystem($fh, $geom, $alloc);
   unless ($self->filehandle) {
      $fh->close or croak "close: $!";
   }
   $log->debug('end VFAT::finish');
   1;
}

sub _log_hexdump($buf) {
   $log->tracef('%04X'.(" %02x"x16), $_, unpack 'C*', substr($buf, $_*16, 16))
      for 0..ceil(length($buf) / 16);
}

sub _write_filesystem($self, $fh, $geom, $alloc) {
   ($alloc->max_cluster_id//-1) == ($geom->max_cluster_id//-1)
      or croak "Max element of 'fat_entries' should be ".$geom->max_cluster_id.", but was ".$alloc->max_cluster_id;
   # Pack the boot sector and other reserved sectors
   my $buf= $self->_pack_reserved_sectors;
   my $ofs= $self->volume_offset;
   write_file_extent($fh, $ofs, $geom->reserved_size, \$buf, 0, 'reserved sectors');
   $ofs += $geom->reserved_size;
   # Pack the allocation tables
   $buf= $self->_pack_allocation_table($alloc);
   # store a copy of this into each of the regions occupied by fats
   for (my $i= 0; $i < $geom->fat_count; $i++) {
      write_file_extent($fh, $ofs, $geom->fat_size, \$buf, 0, "fat table $i");
      $ofs += $geom->fat_size;
   }
   # For FAT12/FAT16, write the root directory entries
   if ($geom->bits < FAT32) {
      my $rootf= $self->root->file;
      die "BUG: mis-sized FAT16 root directory"
         if !$rootf->size || ($rootf->size & 31)
            || length ${$rootf->data} != $rootf->size
            || $rootf->size > $geom->root_dir_size;
      write_file_extent($fh, $ofs, $geom->root_dir_size, $rootf->data, 0, 'root dir');
   }
   # The files and dirs have all been assigned clusters by _optimize_geometry
   for my $cl (sort { $a <=> $b } keys $alloc->chains->%*) {
      my ($invlist, $file)= $alloc->chains->{$cl}->@{'invlist','file'};
      my $data= $file->data;
      # Given an inversion list describing the allocated clusters for this file,
      # write the relevant chunks of the file to those cluster data areas.
      $log->debugf("writing '%s' at cluster %s", $file->name, _render_invlist($invlist))
         if $log->is_debug;
      my $data_ofs= 0;
      for (my $i= 0; $i < @$invlist; $i += 2) {
         my ($cl_start, $cl_lim)= @{$invlist}[$i, $i+1];
         my $size= ($cl_lim-$cl_start) * $geom->bytes_per_cluster;
         write_file_extent($fh, $geom->get_cluster_device_offset($cl_start), $size, $data, $data_ofs);
         $data_ofs += $size;
      }
   }
}
sub _render_invlist($il) {
   join ',',
      map +($il->[$_*2] == $il->[$_*2+1]-1? $il->[$_*2] : $il->[$_*2] . '-' . $il->[$_*2+1]),
      0 .. int($#$il/2)
}


sub is_valid_longname($name) {
   # characters permitted for LFN are all letters numbers and $%'-_@~`!(){}^#&+,;=[].
   # and space and all codepoints above 0x7F.
   # they may not begin with space, and cannot exceed 255 chars.
   !!($name !~ /^(\.+\.?)\z/ # dot and dotdot are reserved
   && $name =~ /^
      [^\x00-\x20\x22\x2A\x2F\x3A\x3C\x3E\x3F\x5C\x7C\x7F]
      [^\x00-\x1F\x22\x2A\x2F\x3A\x3C\x3E\x3F\x5C\x7C]{0,254}
      \z/x);
}

sub is_valid_shortname($name) {
   !!($name eq uc $name
   && $name =~ /^
      [\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D\x7E\x80-\xFF]
      [\x20\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D\x7E\x80-\xFF]{0,7}
      (?: \.
         ( [\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D-\xFF]
           [\x20\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D-\xFF]{0,2}
         )?
      )?
      \z/x);
}

sub is_valid_volume_label($name) {
   # same as shortname but no '.' and space is allowed
   !!($name =~ /^
      [\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D-\xFF]
      [\x20\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D-\xFF]{0,10}
      \z/x);
}

sub remove_invalid_shortname_chars($name, $replacement='_') {
   $name =~ tr/a-z/A-Z/; # perform 'uc' but only for the ASCII range
   $name =~ s/[^\x20\x21\x23-\x29\x2D\x30-\x39\x40-\x5A\x5E-\x7B\x7D\x7E\x80-\xFF]+/$replacement/gr;
}

sub _optimize_geometry($self) {
   # calculate what geometry gives us the best size, when rounding each file to that cluster
   # size vs. the size of the FAT it generates, and also meting the needs of alignment requests
   my $root= $self->root;
   my (@offsets, @aligned, @others);
   my %seen= ( refaddr($root) => 1 );
   for my $dir ($root, values $self->{_subdirs}->%*) {
      for my $ent ($dir->entries->@*) {
         # entry may have a directory ref and not a direct file ref
         my $file= $ent->{file} //= $ent->{dir} && $ent->{dir}->file;
         next unless $file && !$seen{refaddr $file}++;
         push @{$file->device_offset? \@offsets : $file->align? \@aligned : \@others}, $file;
      }
   }
   $log->debugf("_optimize_geometry offsets=%d aligned=%d others=%d",
      scalar @offsets, scalar @aligned, scalar @others);
   # provide stable results
   @offsets= sort { $a->device_offset <=> $b->device_offset } @offsets;
   @aligned= sort { fc $a->name cmp fc $b->name } @aligned;
   @others=  sort { fc $a->name cmp fc $b->name } @others;
   my $min_ofs= min(map $_->device_offset, @offsets);
   my $max_ofs= max(map $_->device_offset + $_->size, @offsets);
   my $max_align= max(0, map $_->align, @aligned);
   my $root_dirent_used= $root->file->size / 32;
   isa_int $root_dirent_used && $root_dirent_used >= 1
      or die "BUG: root must always have one entry";
   my $bytes_per_sector= $self->bytes_per_sector;
   my %fail_reason;
   my $best;
   # If the user defined sectors_per_cluster, we only have one option.
   # Otherwise iterate through all of them to find the best.
   my @spc= defined $self->sectors_per_cluster? ( $self->sectors_per_cluster )
      : (1,2,4,8,16,32,64,128);
   cluster_size: for my $sectors_per_cluster (@spc) {
      my $cluster_size= $sectors_per_cluster * $bytes_per_sector;
      isa_pow2 $cluster_size or die "BUG: cluster_size not a power of 2";
      # Avoid triggering warning about incompatible cluster sizes if a good cluster size was
      # already found.
      last if $best && $cluster_size > 32*1024;
      # Count total sectors used by ->{size} of files and dirs.
      # Don't add root dir until we know it will be FAT32
      my $clusters= 0;
      for (@offsets, @aligned, @others) {
         $clusters += ceil($_->size / $cluster_size);
      }
      $log->tracef("with sectors_per_cluster=%d, would require at least %d clusters",
         $sectors_per_cluster, $clusters);
      $clusters ||= 1;
      my ($reserved, $root_clusters_added);
      # If file alignment is a larger power of 2 than cluster_size, then as long as data_start
      # is aligned to cluster_size there will be a cluster that can satisfy the alignment.
      # If file alignment is a smaller power of 2 than cluster_size, then as long as
      # data_start is aligned to the file alignment, every cluster can satisfy the alignment.
      my $align= min($cluster_size, $max_align);
      if ($align) {
         # But wait, does every device_offset meet this alignment?  If not, give up.
         for (@offsets) {
            if ($_->device_offset & ($align-1)) {
               $fail_reason{$sectors_per_cluster}= "device_offset ".$_->device_offset
                  ." of ".$_->name." conflicts with your alignment request of $align";
               next cluster_size;
            }
         }
      }
      elsif (@offsets) {
         # If not aligning clusters to pow2, might need to align to device_offset.
         # First, every device_offset must have the same remainder modulo cluster_size.
         my ($remainder, $prev);
         for (@offsets) {
            my $r= $_->device_offset & ($cluster_size-1);
            if (!defined $remainder) {
               $remainder= $r;
               $prev= $_;
            } elsif ($remainder != $r) {
               $fail_reason{$sectors_per_cluster}= "file $_->{name} device_offset "
                  .$_->device_offset." modulo cluster_size $cluster_size conflicts with"
                  ." file ".$prev->name." device_offset ".$prev->device_offset;
               next cluster_size;
            }
         }
         if ($remainder) {
            $align= [ $cluster_size, $remainder ];
         } else {
            $align= $cluster_size;
         }
      }
      again_with_more_clusters: {
         # If this number of clusters pushes us into FAT32, also need to add the root directory
         # clusters to the count.
         if (!$root_clusters_added
            && $clusters > Sys::Export::VFAT::Geometry::FAT16_IDEAL_MAX_CLUSTERS()
         ) {
            $root_clusters_added= ceil($root->file->size / $cluster_size);
            $clusters += $root_clusters_added;
            $log->tracef("reached FAT32 threshold, adding %s clusters for root dir", $root_clusters_added);
         }
         my $geom= Sys::Export::VFAT::Geometry->new(
            volume_offset          => $self->volume_offset,
            (align_clusters        => $align)x!!$align,
            bytes_per_sector       => $bytes_per_sector,
            sectors_per_cluster    => $sectors_per_cluster,
            fat_count              => $self->fat_count,
            cluster_count          => $clusters,
            used_root_dirent_count => $root_dirent_used,
            min_bits               => $self->min_bits,
         );
         $log->debugf("testing clusters=%d size=0x%X data_region=0x%X-%X min_ofs=0x%X max_ofs=0x%X",
            $clusters, $cluster_size, $geom->data_start_device_offset, $geom->data_limit_device_offset,
            $min_ofs, $max_ofs);
         if (@offsets || @aligned) {
            # tables are too large? Try again with larger clusters.
            if (defined $min_ofs && $min_ofs < $geom->data_start_device_offset) {
               $fail_reason{$sectors_per_cluster}= "FAT tables too large for requested device_offset $min_ofs";
               next cluster_size;
            }
            # Not enough clusters?  Try again with more.
            if (defined $max_ofs && $max_ofs > $geom->data_limit_device_offset) {
               # This might overshoot a bit since the tables also grow and push forward the
               # whole data area.
               $clusters= ceil(($max_ofs - $geom->data_start_device_offset) / $cluster_size);
               goto again_with_more_clusters;
            }
         }
         # Now verify we have enough clusters by actually alocating them
         my $alloc= Sys::Export::VFAT::AllocationTable->new;
         my %assignment;
         unless (eval {
            $self->_alloc_file($geom, $alloc, $_)
               for @offsets, @aligned, @others, ($geom->bits == FAT32? ($root->file) : ());
            1
         }) {
            chomp($fail_reason{$sectors_per_cluster}= "$@");
            next cluster_size;
         }
         if ($alloc->max_used_cluster_id > $geom->max_cluster_id) {
            $clusters= $alloc->max_used_cluster_id-1;
            goto again_with_more_clusters;
         }
         # Allocation worked, so clamp the allocator to this nmber of sectors
         $alloc->max_cluster_id($geom->max_cluster_id);
         # Is this the smallest option so far?
         if (!$best || $best->{geom}->total_sector_count > $geom->total_sector_count) {
            $best= { geom => $geom, alloc => $alloc, cluster_assignment => \%assignment };
         }
      }
   } continue {
      $log->tracef("%s", $fail_reason{$sectors_per_cluster})
         if defined $fail_reason{$sectors_per_cluster};
   }
   if (!$best) {
      $log->debug("no cluster size works");
      $self->{_optimize_geometry_fail_reason}= \%fail_reason;
      return;
   }
   $log->debugf("best cluster_size is %d", $best->{geom}->bytes_per_cluster);
   return @{$best}{'geom','alloc'};
}

# reserve clusters for a file according to the align/offset needs of that file
sub _alloc_file($self, $geom, $alloc, $file) {
   my $sz= $file->size or do { carp "Attempt to allocate zero-length file"; return };
   my $cl_count= POSIX::ceil($sz / $geom->bytes_per_cluster);
   my $cl_start;
   if ($file->device_offset) {
      my ($cl, $n)= $geom->get_cluster_extent_of_device_extent($file->device_offset, $sz);
      $cl_start= $alloc->alloc_range($cl, $cl_count)
         // croak "Can't allocate $cl_count clusters from offset ".$file->device_offset;
   } elsif ($file->align) {
      my ($mul, $ofs)= $geom->get_cluster_alignment_of_device_alignment($file->align);
      $cl_start= $alloc->alloc_contiguous($cl_count, $mul, $ofs)
         // croak "Can't allocate $cl_count clusters aligned to ".$file->align;
   } else {
      $cl_start= $alloc->alloc($cl_count)
         // croak "Can't allocate $cl_count clusters";
   }
   $alloc->{chains}{$cl_start}{file}= $file;
   $cl_start;
}

# store the cluster and device offset into the File objects
sub _commit_allocation($self) {
   my $alloc= $self->allocation_table;
   my $geom= $self->geometry;
   # Apply file cluster IDs to the File objects
   for (values $alloc->chains->%*) {
      my $file= $_->{file};
      $file->{cluster}= $_->{invlist}[0];
      # Only set offset if file is contiguous
      $file->{device_offset} //= $geom->get_cluster_device_offset($file->{cluster})
         if 2 == @{$_->{invlist}};
   }
}

our @sector0_fields_common= (
   [ BS_jmpBoot     =>    0,  3, 'a3', '' ],
   [ BS_OEMName     =>    3,  8, 'a8', 'MSWIN4.1' ],
   [ BPB_BytsPerSec =>   11,  2, 'v' ],
   [ BPB_SecPerClus =>   13,  1, 'C' ],
   [ BPB_RsvdSecCnt =>   14,  2, 'v' ],
   [ BPB_NumFATs    =>   16,  1, 'C' ],
   [ BPB_RootEntCnt =>   17,  2, 'v' ],
   [ BPB_TotSec16   =>   19,  2, 'v' ],
   [ BPB_Media      =>   21,  1, 'C', 0xF8 ],
   [ BPB_FATSz16    =>   22,  2, 'v' ],
   [ BPB_SecPerTrk  =>   24,  2, 'v', 0 ],
   [ BPB_NumHeads   =>   26,  2, 'v', 0 ],
   [ BPB_HiddSec    =>   28,  4, 'V', 0 ],
   [ BPB_TotSec32   =>   32,  4, 'V'  ]
);
our @sector0_fat16_fields= (
   @sector0_fields_common,
   [ BS_DrvNum      =>   36,  1, 'C', 0x80 ],
   [ BS_Reserved1   =>   37,  1, 'C', 0 ],
   [ BS_BootSig     =>   38,  1, 'C', 0x29 ],
   [ BS_VolID       =>   39,  4, 'V' ],
   [ BS_VolLab      =>   43, 11, 'A11', 'NO NAME' ],
   [ BS_FilSysType  =>   54,  8, 'A8' ],
   [ _signature     =>  510,  2, 'v', 0xAA55 ],
);
our @sector0_fat32_fields= (
   @sector0_fields_common,
   [ BPB_FATSz32    =>   36,  4, 'V' ],
   [ BPB_ExtFlags   =>   40,  2, 'v', 0 ],
   [ BPB_FSVer      =>   42,  2, 'v', 0 ],
   [ BPB_RootClus   =>   44,  4, 'V' ],
   [ BPB_FSInfo     =>   48,  2, 'v' ],
   [ BPB_BkBootSec  =>   50,  2, 'v', 0 ],
   [ BPB_Reserved   =>   52, 12, 'a12', '' ],
   [ BS_DrvNum      =>   64,  1, 'C', 0x80 ],
   [ BS_Reserved1   =>   65,  1, 'C', 0 ],
   [ BS_BootSig     =>   66,  1, 'C', 0x29 ],
   [ BS_VolID       =>   67,  4, 'V' ],
   [ BS_VolLab      =>   71, 11, 'A11', 'NO NAME' ],
   [ BS_FilSysType  =>   82,  8, 'A8' ],
   [ _signature     =>  510,  2, 'v', 0xAA55 ],
);
our @fat32_fsinfo_fields= (
   [ FSI_LeadSig    =>    0,  4, 'V', 0x41615252 ],
   [ FSI_Reserved1  =>    4,480, 'a480', '' ],
   [ FSI_StrucSig   =>  484,  4, 'V', 0x61417272 ],
   [ FSI_Free_Count =>  488,  4, 'V', 0xFFFFFFFF ],
   [ FSI_Nxt_Free   =>  492,  4, 'V', 0xFFFFFFFF ],
   [ FSI_Reserved2  =>  496, 12, 'a12', '' ],
   [ FSI_TrailSig   =>  508,  4, 'V', 0xAA550000 ],
);
sub _append_pack_args($pack, $vals, $ofs, $fields, $attrs) {
   for (@$fields) {
      push @$pack, '@'.($ofs+$_->[1]).$_->[3];
      push @$vals, $attrs->{$_->[0]} // $_->[4]
         // croak "No value supplied for $_->[0], and no default";
   }
}

sub _epoch_to_fat_date_time($epoch) {
   my @lt = localtime($epoch);
   my $year = $lt[5] + 1900;
   my $mon  = $lt[4] + 1;
   my $mday = $lt[3];
   my $hour = $lt[2];
   my $min  = $lt[1];
   my $sec  = int($lt[0] / 2); # 2-second resolution

   $year = 1980 if $year < 1980;
   my $fat_date = (($year - 1980) << 9) | ($mon << 5) | $mday;
   my $fat_time = ($hour << 11) | ($min << 5) | $sec;
   my $fat_frac = ($epoch * 100) % 200;
   return ($fat_date, $fat_time, $fat_frac);
}

# This packs the boot sector and all the "reserved" sectors that appear before the
# beginning of the allocation tables.
sub _pack_reserved_sectors($self, %attrs) {
   my (@pack, @vals);
   my $geom= $self->geometry;
   $attrs{BPB_BytsPerSec}= $geom->bytes_per_sector;
   $attrs{BPB_SecPerClus}= $geom->sectors_per_cluster;
   $attrs{BPB_RsvdSecCnt}= $geom->reserved_sector_count;
   $attrs{BPB_NumFATs}=    $geom->fat_count;
   $attrs{BPB_RootEntCnt}= $geom->root_dirent_count;
   $attrs{BS_VolLab} //= $self->volume_label;
   $attrs{BS_VolID} //= time & 0xFFFFFFFF;
   if ($geom->bits < FAT32) {
      $attrs{BPB_FATSz16}= $geom->fat_sector_count < 0x10000? $geom->fat_sector_count : 0;
      $attrs{BPB_FATSz32}= $geom->fat_sector_count < 0x10000? 0 : $geom->fat_sector_count;
      $attrs{BPB_TotSec16}= $geom->total_sector_count < 0x10000? $geom->total_sector_count : 0;
      $attrs{BPB_TotSec32}= $geom->total_sector_count < 0x10000? 0 : $geom->total_sector_count;
      $attrs{BS_FilSysType}= $geom->bits == 12? 'FAT12' : 'FAT16';
      _append_pack_args(\@pack, \@vals, 0, \@sector0_fat16_fields, \%attrs);
   } else {
      # Did the user specify location of fsinfo?  If not, default to sector 1
      $attrs{BPB_FSInfo} //= 1;
      $attrs{BPB_BkBootSec} //= 2;
      $attrs{BPB_FATSz16}= 0;
      $attrs{BPB_FATSz32}= $geom->fat_sector_count;
      $attrs{BPB_RootClus}= $self->root->file->cluster;
      $attrs{BPB_TotSec16}= 0;
      $attrs{BPB_TotSec32}= $geom->total_sector_count;
      $attrs{BS_FilSysType}= "FAT";
      _append_pack_args(\@pack, \@vals, 0, \@sector0_fat32_fields, \%attrs);

      # FSInfo struct, location is configurable
      my $fsi_ofs= $attrs{BPB_FSInfo} * $attrs{BPB_BytsPerSec};
      $attrs{FSI_Free_Count} //= $self->allocation_table->free_cluster_count;
      $attrs{FSI_Nxt_Free}   //= $self->allocation_table->first_free_cluster;
      _append_pack_args(\@pack, \@vals, $fsi_ofs, \@fat32_fsinfo_fields, \%attrs);

      # Backup copy of boot sector
      my $bk_ofs= $attrs{BPB_BkBootSec} * $attrs{BPB_BytsPerSec};
      _append_pack_args(\@pack, \@vals, $bk_ofs, \@sector0_fat32_fields, \%attrs);
      _append_pack_args(\@pack, \@vals, $bk_ofs+$fsi_ofs, \@fat32_fsinfo_fields, \%attrs);
   }
   pack join(' ', @pack), @vals;
}

# This packs one allocation table and returns the buffer
sub _pack_allocation_table($self, $alloc) {
   my $fat= [ $alloc->fat->@* ];
   croak "Allocation table used more clusters than configured in geometry"
      if $self->geometry->max_cluster_id < ($alloc->max_cluster_id // $alloc->max_used_cluster_id);
   my $max= $self->geometry->max_cluster_id;
   $#$fat= $max;
   $fat->[$_]= 0x0FFFFFFF for 0,1;
   $fat->[$_] //= 0 for 2..$max;   # prevent warnings in pack
   if ($self->geometry->bits == 32) {
      return pack 'V*', @$fat;
   } elsif ($self->geometry->bits == 16) {
      return pack 'v*', @$fat;
   } else {
      # 12 bits per entry, pack in groups of 3 bytes, little-endian
      my $buf= "\xFF\xFF\xFF";
      for (my $i= 2; $i+1 <= $max; $i+= 2) {
         my $v= ($fat->[$i] & 0xFFF) | ( ($fat->[$i+1] & 0xFFF) << 12 );
         $buf .= pack 'vC', $v, ($v >> 16);
      }
      $buf .= pack 'v', $fat->[$max] & 0xFFF unless $max & 1;
      return $buf;
   }
}

# This calculates the encoded size of one directory
sub _calc_dir_size($self, $dir) {
   # If an autovivified directoy lacks a ->{file}, create it.
   $dir->{file} //= Sys::Export::VFAT::File->new(name => $dir->name, flags => ATTR_DIRECTORY);
   my $ents= $dir->entries;
   # Need the 8.3 name in order to know whether it matches the long name
   $dir->build_shortnames;
   # root dir has a volume label ent, and all other dirs have '.' and '..'
   my $n= @$ents + ($dir->is_root? 1 : 2);
   for (@$ents) {
      # Add LFN entries
      if ($_->{name} ne $_->{shortname}) {
         my $utf16= encode('UTF-16LE', $_->{name}, Encode::FB_CROAK|Encode::LEAVE_SRC);
         $n += ceil(length($utf16) / 26);
      }
   }
   $log->debugf("dir %s has %d real entries, %d LFN entries, size=%d ents=%s",
      $dir->name, scalar(@$ents), $n-scalar @$ents, $n*32,
      [ map +( $_->{name} eq $_->{shortname}? $_->{name} : [ @{$_}{'name','shortname'} ] ), @$ents ])
      if $log->is_debug;
   croak "Directory ".$dir->name." exceeds maximum entry count ($n >= 65536)"
      if $n >= 65536;
   $dir->file->{size}= $n * 32;  # always 32 bytes per dirent
}

# Pack one directory and return the buffer
sub _pack_directory($self, $dir) {
   my $data= '';
   my @special= $dir->is_root? (
      { short11 => $self->volume_label // 'NO NAME    ', flags => ATTR_VOLUME_ID },
   ) : (
      { short11 => ".",  flags => ATTR_DIRECTORY, file => $dir->file },
      { short11 => '..', flags => ATTR_DIRECTORY, file => $dir->parent->file },
   );
   for my $ent (@special, sort { lc $a->{name} cmp lc $b->{name} } $dir->entries->@*) {
      my ($name, $file, $shortname, $short11)= @{$ent}{qw( name file shortname short11 )};
      $log->tracef("encoding dirent short=%-12s long=%s cluster=%s",
         $shortname//$short11, $name, $file && $file->cluster);

      unless (length $short11) {
         my ($base, $ext)= split /\./, $shortname;
         $short11= pack 'A8 A3', $base, ($ext//'');
      }
      $short11 =~ s/^\xE5/\x05/; # \xE5 may occur in some charsets, and needs escaped

      # Need Long-File-Name entries?
      if (defined $name && $name ne $shortname) {
         # Checksum for directory shortname, used to verify long name parts
         my $cksum= 0;
         $cksum= ((($cksum >> 1) | ($cksum << 7)) + $_) & 0xFF
            for unpack 'C*', $short11;
         # Each dirent holds up to 26 bytes (13 chars) of the long name
         my @chars= unpack 'v*', encode('UTF-16LE', $name, Encode::FB_CROAK|Encode::LEAVE_SRC);
         # short final chunk is padded with \0\uFFFF*
         if (my $remainder= @chars % 13) {
            push @chars, 0;
            push @chars, (0xFFFF)x(12 - $remainder);
         }
         my $last= ceil(@chars/13) - 1;
         for my $i (reverse 0..$last) {
            my $ofs= $i*13;
            my $seq= ($i + 1) | (($i == $last) ? 0x40 : 0x00);
            $data .= pack('C v5 C C C v6 v v2',
               $seq,                      # sequence and end-flag
               @chars[$ofs .. $ofs+4],    # first 5 chars
               0x0F, 0x00, $cksum,        # attr = LFN, type = 0
               @chars[$ofs+5 .. $ofs+10], # next 6 chars
               0,                         # no cluster number
               @chars[$ofs+11 .. $ofs+12] # last 2 chars
            );
         }
      }

      my $mtime= $ent->{mtime} // ($file && $file->mtime) // time;
      my $atime= $ent->{atime} // ($file && $file->atime) // $mtime;
      my $btime= $ent->{btime} // ($file && $file->btime) // $mtime;
      my ($wdate, $wtime)             = _epoch_to_fat_date_time($mtime);
      my ($cdate, $ctime, $ctime_frac)= _epoch_to_fat_date_time($btime);
      my ($adate)                     = _epoch_to_fat_date_time($atime);
      my $flags= $ent->{flags} // ($file && $file->flags) // 0;
      # References to the root dir are always encoded as cluster zero, even on FAT32
      # where the root dir actually lives at a nonzero cluster.
      # Volume label also doesn't need a cluster id.  Nor do empty files.
      my $cluster= 0;
      if ($file && $file != $self->root->file) {
         $cluster= $file->cluster // croak "File ".$file->name." lacks a defined cluster id";
      }
      # Directories always written as size = 0
      my $size= !$file? 0 : $file->is_dir? 0 : $file->size;
      $log->tracef(" with encoded size=%d cluster=%d", $size, $cluster);
      $data .= pack('A11 C C C v v v v v v v V',
         $short11, $flags, 0, #NT_reserved
         $ctime_frac, $ctime, $cdate, $adate,
         $cluster >> 16, $wtime, $wdate, $cluster, $size);
   }
   die "BUG: calculated dir size ".$dir->file->size." != data length ".length($data)
      unless $dir->file->size == length $data;
   # Dir must be padded to length of sector/cluster with entries whose name begins with \x00
   # but that will happen automatically later as the data is appended to the file.
   $dir->file->{data}= \$data;
}

# Avoiding dependency on namespace::clean
delete @{Sys::Export::VFAT::}{qw(
   carp croak confess encode decode min max ceil blessed dualvar refaddr weaken S_ISDIR S_ISREG
   expand_stat_shorthand isa_array isa_handle isa_hash isa_int isa_pow2 write_file_extent
)};
1;

__END__