view release on metacpan or  search on metacpan

bin/defrag  view on Meta::CPAN

   stat_ok or $s_skipped++, return; # skip if file looks fishy

   my $max_extents = int +($size + CHUNK - 1) / CHUNK;

   my $extents = file_extents $src_fh, MAX_GAP
      or $s_skipped++, return; # maybe file with holes, or not yet flushed to disk

   $extents > $max_extents or $s_linear++, return; # cool, "it's unfragmented"

   !$opt_inuse and file_inuse $path
      and $s_skipped++, return; # skip files that are currently open
      
   print "$dir/$file: ";
   printf "$extents ";

   my $dst = "$dir/.defrag.$$";
   #my $dst = "/.defrag.$$";

   $cleanup{$dst} = $dst;
   
   my $dst_fh = direct_open $dst, O_RDWR | O_CREAT | O_EXCL, 0600
      or die "$dst: unable to create new copy\n";

   my $index = 0;

   my $chunksize = $size < 1<<20 ? 1<<20 : CHUNK;

   while (direct_copy $src_fh, $dst_fh, $chunksize, $index) {
      $index++;

      if ((stat $src_fh)[9] != $mtime) {
         print "file was modified, skipping.\n";
         $s_skipped++, goto bailout;
      }
   }

   my $after_extents = file_extents $dst_fh, MAX_GAP
      or $s_skipped++, goto bailout;

   print "=> $after_extents ";

   if ($after_extents >= $extents) {
      print "couldn't achieve fewer extents, skipping.\n";
      $s_fragmented++, goto bailout;
   } elsif ($after_extents > 1) {
      $s_improved++;
   } else {
      $s_perfect++;
   }

   truncate $dst, $size
      or die "$dst: unable to truncate copy to correct size\n";

   (stat $dst_fh)[7] == $size
      or die "$dst: file size mismatch\n";

   close $dst_fh
      or $s_skipped++, goto bailout;

   chown $uid, $gid, $dst
      or $s_skipped++, goto bailout;

   chmod $mode, $dst
      or $s_skipped++, goto bailout;

   utime $atime, $mtime, $dst
      or $s_skipped++, goto bailout;

   my $token = $opt_nofreeze || Sys::FreezeThaw::freeze;

      # the next is very slow, unfortunately
      !$opt_inuse and file_inuse $path
         and die "file is in use by some process\n";

      lstat $path
         or die "$path: unable to stat\n";

      (stat _)[ 0] == $device or die "device differs (WTF?)\n";
      (stat _)[ 1] == $inode  or die "inode differs\n";
      (stat _)[ 4] == $uid    or die "uid differs\n";
      (stat _)[ 5] == $gid    or die "gid differs\n";
      (stat _)[ 7] == $size   or die "size differs\n";
      (stat _)[ 9] == $mtime  or die "modification time differs\n";
      (stat _)[10] == $ctime  or die "change time differs\n";

      rename $dst, $path
         or die "rename over destination: $!";

   $opt_nofreeze or Sys::FreezeThaw::thaw $token;

   print "done.\n";

   delete $cleanup{$dst};

   return;

bailout:
   unlink delete $cleanup{$dst};
}

sub defrag_files {
   my @files = @_;

   while (@files) {
      my $path = shift @files;
      lstat $path;

      if (-d _) {
         # traverse directories, depth first
         opendir my $dir, $path
            or next;

         unshift @files, map "$path/$_",
                            sort
                               grep $_ ne "." && $_ ne "..",
                                  readdir $dir;
      } elsif (-f _) {
         stat_ok or next;

         defrag_file $path;