File Coverage

blib/lib/Sys/Export/VFAT/AllocationTable.pm

Criterion	Covered	Total	%
statement	154	166	92.7
branch	47	82	57.3
condition	19	50	38.0
subroutine	22	23	95.6
pod	13	13	100.0
total	255	334	76.3

package Sys::Export::VFAT::AllocationTable;

# ABSTRACT: Track which FAT clusters are used, and by what
our $VERSION = '0.005_002'; # TRIAL VERSION


# Element 0 of the FAT is used for an inversion list of which sectors are allocated.
# It's not as good as a tree, but should perform well when the typical use case is
# to pack files end to end without fragmentation.
use v5.26;
use warnings;
use experimental qw( signatures );
use Scalar::Util 'refaddr';
use Carp;
use Sys::Export qw( isa_int );
use Sys::Export::VFAT::Geometry qw( FAT12_MAX_CLUSTERS FAT16_MAX_CLUSTERS FAT32_MAX_CLUSTERS );


sub fat            { $_[0]{fat} }
sub _invlist       { $_[0]{_invlist} }
sub chains         { $_[0]{chains} }
sub max_cluster_id { @_ > 1? $_[0]->set_max_cluster_id($_[1]) : $_[0]{max_cluster_id} }
sub max_used_cluster_id { $_[0]{_invlist}[-1] - 1 }


sub first_free_cluster {
   my ($first_free, $max)= ($_[0]{_invlist}[1], $_[0]{max_cluster_id});
   defined $max && $first_free > $max? undef : $first_free;
}


sub set_max_cluster_id($self, $val) {
   if (defined $val) {
      my $min= $self->max_used_cluster_id;
      croak "Cannot set max_cluster_id less than max_used_cluster_id"
         if defined $min && $val < $min;
      croak "Cannot set max_cluster_id less than 2"
         if $val < 2;
   }
   $self->{max_cluster_id}= $val;
}


sub free_cluster_count($self) {
   my ($sum, $inv, $max)= (0, $self->{_invlist}, $self->{max_cluster_id});
   for (my $i= 1; $i < $#$inv; $i += 2) {
      $sum += $inv->[$i+1] - $inv->[$i];
   }
   $sum += $max - ($inv->[-1]-1) if defined $max;
   return $sum;
}


sub get_chain($self, $cl_id) {
   $self->{chains}{$cl_id};
}


sub new($class, @attrs) {
   my %attrs= @attrs == 1 && ref $attrs[0] eq 'HASH'? %{$attrs[0]} : @attrs;
   my $max_cluster_id= delete $attrs{max_cluster_id};
   croak "Invalid max_cluster_id"
      unless !defined $max_cluster_id or isa_int $max_cluster_id && $max_cluster_id >= 2;
   carp "Unrecognized attributes ".join(', ', keys %attrs)
      if keys %attrs;

   bless {
      max_cluster_id => $max_cluster_id,
      fat => [],
      _invlist => [ 0, 2 ], # mark 0-1 as allocated, to remove empty-list edge cases
      chains => {},
   }, $class;
}


sub alloc($self, $count) {
   return 0 unless $count;
   croak "Cluster count must be an unsigned integer"
      unless isa_int $count && $count > 0;
   my $inv= $self->{_invlist};
   my $lim= $self->{max_cluster_id}? $self->{max_cluster_id}+1 : undef;
   # If there are enough free sectors, this basically just removes gaps in the inversion list.
   for (my $i= 1; $i < @$inv; $i+= 2) {
      my ($from, $upto)= @{$inv}[$i,$i+1];
      my $n= defined $upto? ($upto - $from) : undef;
      if (!defined $n || $n >= $count) {
         my @result;
         if (!defined $n) { # allocate from final region up to max sector
            last if defined $lim && $lim - $from < $count;
            @result= (splice(@$inv, 1, $i, $from + $count), $from+$count);
         }
         elsif ($n == $count) { # result comes from exactly the gaps between other allocation
            @result= splice(@$inv, 1, $i+1);
         }
         else { # result comes from partial gap
            @result= (splice(@$inv, 1, $i-1), $from, $from+$count);
            $inv->[1]= $from + $count;
         }
         # and build the cluster chain in the FAT
         my $prev= 0;
         for (my $j= 0; $j < @result; $j += 2) {
            for ($result[$j] .. ($result[$j+1]-1)) {
               $self->{fat}[$prev]= $_ if $prev;
               $prev= $_;
            }
         }
         $self->{fat}[$prev]= 0x0FFFFFFF;
         $self->{chains}{$result[0]}{invlist}= \@result;
         return $result[0];
      }
      $count -= $n;
   }
   return undef; # not enough available
}


sub alloc_range($self, $cluster_id, $count) {
   return 0 unless $count;
   croak "Cluster count must be an unsigned integer"
      unless isa_int $count && $count > 0;
   croak "Invalid cluster id '$cluster_id'"
      unless isa_int $cluster_id && $cluster_id >= 2;
   return $self->_alloc_range($cluster_id, $cluster_id + $count);
}


sub alloc_contiguous($self, $count, $align=1, $align_ofs=0) {
   return 0 unless $count;
   croak "Cluster count must be an unsigned integer"
      unless isa_int $count && $count > 0;
   my $inv= $self->{_invlist};
   for (my $i= 1; $i < @$inv; $i+=2) {
      my ($from, $upto)= @{$inv}[$i, $i+1];
      my $start= $from;
      # Align start addr
      if ($align > 1) {
         my $remainder= ($start - $align_ofs) & ($align-1);
         $start += $align - $remainder if $remainder;
      }
      # Is the range large enough?
      next if defined $upto && $upto - $start < $count;
      return $self->_alloc_range($start, $start+$count, $i);
   }
   return undef;
}

# add the range ($start, $lim) to an inversion list where idx is pointed at
# the first range that wasn't entirely before $start
sub _invlist_alloc($inv, $start, $lim, $idx=undef) {
   unless (defined $idx) {
      for ($idx= 0; $idx < $#$inv && $inv->[$idx+1] <= $start; $idx++) {}
      # here, [idx] is less/eq start, and [idx+1] is not (or doesn't exist)
      # If idx is even, it means start fell within an allocated range
      return 0 unless $idx & 1;
   }
   my $from_edge= $inv->[$idx] == $start;
   # allocating at the end
   if ($idx == $#$inv) {
      # max_cluster_id was checked by caller
      $from_edge? ($inv->[$idx]= $lim)
      : push(@$inv, $start, $lim);
   }
   else {
      # does 'lim' exceed the gap between allocations?
      return 0 if $lim > $inv->[$idx+1];
      my $to_edge= $lim == $inv->[$idx+1];
      $from_edge && $to_edge? splice(@$inv, $idx, 2)
      : $from_edge?           ($inv->[$idx]= $lim)
      : $to_edge?             ($inv->[$idx+1]= $start)
      : splice(@$inv, $idx+1, 0, $start, $lim);
   }
   return 1;
}

sub _alloc_range($self, $cl_start, $cl_lim, $invlist_idx=undef) {
   return undef if $self->max_cluster_id && $cl_lim-1 > $self->max_cluster_id;
   return undef unless _invlist_alloc($self->{_invlist}, $cl_start, $cl_lim, $invlist_idx);
   # Build the cluster chain in the FAT
   $self->{fat}[$_]= $_+1
      for $cl_start .. $cl_lim-2;
   $self->{fat}[$cl_lim-1]= 0x0FFFFFFF;
   # An allocation inversion list of one segment
   $self->{chains}{$cl_start}{invlist}= [ $cl_start, $cl_lim ];
   return $cl_start;
}


sub pack($self, $bits=undef) {
   my $fat= $self->fat;
   my $max= $self->max_cluster_id // $self->max_used_cluster_id;
   my $cl_count= $max-1; # excluding clusters 0 and 1
   croak "Max cluster ID exceeds FAT32 max" if $cl_count > FAT32_MAX_CLUSTERS;
   carp "Truncating table to cluster id $max" if $max < $#$fat;
   $#$fat= $max;
   $fat->[$_]= 0x0FFFFFFF for 0,1;
   $fat->[$_] //= 0 for 2..$max;   # prevent warnings in pack
   if ($cl_count > FAT16_MAX_CLUSTERS) {
      return pack 'V*', @$fat;
   } elsif ($cl_count > FAT12_MAX_CLUSTERS) {
      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;
   }
}

# Avoiding dependency on namespace::clean
delete @{Sys::Export::VFAT::AllocationTable::}{qw( carp confess croak refaddr isa_int )};
1;

__END__