# FileCopy.pm
# Author: Noah Friedman <friedman@splode.com>
# Created: 2000-01-14
# Public domain.

# $Id: FileCopy.pm,v 1.1 2000/03/01 09:51:08 friedman Exp $

# Commentary:

# The File::Copy module doesn't provide the option of preserving timestamps
# or other file attributes when copying/moving across filesystem
# boundaries.

# Code:

package NF::FileCopy;

use NF::Diag;
use Fcntl;
use POSIX qw(:errno_h :sys_wait_h);
use Symbol;
use strict;

use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT      = qw(copy_file
                  move_file
                  make_backup_file_name
                  backup_file
                  file_directory
                  files_writable_by_uid
                  xunlink
                  xrmdir
                  xstat);
@EXPORT_OK   = qw(set_file_stats);


sub verbose (;@)
{
  diag_info (0, join (" ",  @_));
}

sub xunlink ($;$)
{
  my $file = shift;
  my $ignore_if_nonexist = shift;

  return undef if (defined $ignore_if_nonexist
                   && $ignore_if_nonexist
                   && ! -e $file);

  verbose ("unlinking", $file);
  unlink ($file) || return diag_error (1, "unlink", $file, $!);
}

sub xrmdir ($;$)
{
  my $dir = shift;
  my $ignore_if_nonexist = shift;

  return undef if (defined $ignore_if_nonexist
                   && $ignore_if_nonexist
                   && ! -e $dir);

  verbose ("removing directory", $dir);
  rmdir ($dir) || return diag_error (1, "rmdir", $dir, $!);
}

sub xstat ($;$)
{
  my $file = shift;
  my $noerrp = shift || 0;

  my @statinfo = stat $file;
  return \@statinfo if (defined @statinfo);
  return undef if ($noerrp);
  diag_error (1, "stat", (ref $file ? fileno ($file) : $file), $!);
}

sub set_file_stats ($$;$)
{
  my $file = shift;
  my $statinfo = shift;
  my $actions = shift || 1;

  # Set file permissions
  (chmod ($statinfo->[2], $file)
   || return diag_error (1, sprintf ("chmod(%o)", $statinfo->[2]), $file, $!))
    if ($actions & 1);

  # Set atime/mtime
  utime ($statinfo->[8], $statinfo->[9], $file) if ($actions & 2);
  # Set owner/group
  chown ($statinfo->[4], $statinfo->[5], $file) if ($actions & 4);

  return 1;
}

sub copy_file ($$;$$)
{
  my ($from, $to, $preserve, $returnstatp, $clobberp) = @_;
  my $fh_from = gensym;
  my $fh_to   = gensym;

  verbose ("copying", $from, "->", $to);

  $clobberp = 1 unless (defined $clobberp);
  my $oflag = $clobberp ? O_TRUNC : O_EXCL;

  sysopen ($fh_from, $from, O_RDONLY) || return diag_error (5, "open", $from, $!);
  if (!sysopen ($fh_to, $to, O_WRONLY | O_CREAT | $oflag, 0600))
    {
      close ($fh_from);
      diag_error (5, "open", $to, $!);
      return undef;
    };

  my $data;
  while (my $len = sysread ($fh_from, $data, 2**20)) # 1mb buffer
    {
      if (syswrite ($fh_to, $data, $len) != $len)
        {
          diag_error (5, "write", $to, $!);
          close ($fh_from);
          close ($fh_to);
          return undef;
        }
    }

  my @fromstat = stat ($fh_from);
  my @tostat   = stat ($fh_to) if ($returnstatp);
  close ($fh_from);
  close ($fh_to);

  return [ \@fromstat, \@tostat ] if ($returnstatp);

  set_file_stats ($to, \@fromstat, ($preserve ? 1|2|4 : 1));
  return 1;
}

sub move_file ($$)
{
  my ($from, $to) = @_;

  verbose ("moving", $from, "->", $to);
  return 1 if (rename ($from, $to));

  return diag_error (join (" -> ", $from, $to), $!)
    unless ($!+0 == EXDEV);

  verbose ("file must be copied to different filesystem");
  if (copy_file ($from, $to, 1))
    {
      xunlink ($from);
      return 1;
    }
  return undef;
}

sub make_backup_file_name ($;$)
{
  my $file = shift;
  my $vc = lc (shift) || '';

  return $file . "~" if ($vc eq 'never' || $vc eq 'simple');

  my $dir = ".";
  my $base = $file;
  if (index ($file, "/") >= $[)
    {
      $base =~ s|.*/||o;
      $dir = $file;
      $dir =~ s|/[^/]*$||o;
    }

  my $dfh = gensym;
  opendir ($dfh, $dir) || return diag_error (1, "opendir", $dir, "$!");
  my $m = eval 'sub { m/^' . quotemeta ($base) . '\.~(\d+)~$/o && $1 }';
  my $h = [sort { -($a <=> $b) } grep { $_ = &$m } readdir $dfh]->[0];
  closedir ($dfh);

  return join ("", $file, ".~", $h + 1, "~") if (defined $h);
  join ("", $file, ($vc eq 'numbered' || $vc eq 't' ? ".~1~" : "~"));
}

sub backup_file ($$)
{
  my ($from, $to) = @_;
  my $fromstat = xstat ($from);

  # Backup by copying if file has multiple hard links
  return copy_file ($from, $to, 1) if ($fromstat->[3] > 1);

  # Backup by rename; new version will be in new file.
  verbose ("renaming", $from, "->", $to);
  rename ($from, $to) || diag_error (1, "rename", join (" ", $from, "->", $to), $!);
}

# Return the directory name where file resides.
sub file_directory ($)
{
  # modify a copy of the argument.  Editing $_[0] directly would affect the
  # original value.
  my $file = shift;
  return "." unless (index ($file, "/") >= $[);
  $file =~ s|/[^/]*$||o;
}

# This function assumes process is running as root at can change uids
sub files_writable_by_uid ($@)
{
  my $uid = shift;
  my $pid = fork;
  if ($pid == 0)
    {
      # Set real and effective uid to $uid
      $< = $> = $uid;
      my $i = 0;
      foreach (@_) { $i++ if (-w) };
      exit ($i);
    }
  waitpid ($pid, 0);
  return $? >= 255 ? $? - 255 : $?;
}

1;