=head1 NAME

CFX5::FileTests - Test for properties of files

=head1 SYNOPSIS

Various tests for files, such as whether or not the file is
executable, for use as generic functions. These have several
advantages over the L<-X> operators provided by Perl:

=over

=item Portability

Want to know if a directory is accessible? Don't want to have to work
out whether to test -x it? Look no further!

=item Complete

To find out if a filename is a valid replacement for the Build
executable, you need to know that it's executable, and also that it's
not a directory.

=item Helpful

Because these are generic functions, the error messages can be made
much more complete with a minimum of extra effort.

=back

None of these functions are exported; you must do (for example)
  CFX5::FileTests::execfile($file)
instead. Unless otherwise stated, the first argument is the name of
the file to test, and the optional second argument gives context (for
mple, "passed to -exec"). They use the C<_error> function to signal
errors: you should use C<_exit_if_errors> after a code segment calling
these functions to pick this up. They also return 1 (true) on success
and 0 (false) on failure.

=cut '

package CFX5::FileTests;

use vars qw($CVSVersion);
$CVSVersion='$Id$ ';

use strict;

use CFX5::Output qw(:all);
use CFX5::PathManip qw(split_file join_file fullpath);

use CFX5::Config qw(%Config);

use CFX5::FileStat;

=head1 FUNCTION LISTING

=head3 trust_file_bits

Internal call.  Reads the config variable CFX5_IGNORE_PERMISSION_BITS,
and returns TRUE if we should not ignore them, and FALSE if we
should. This is for use on systems which use extended ACLs, for
example.  Particularly, Windows systems sometimes set the readonly bit
on directories (My Documents?!) which are entirely writable.

If we're ignoring them, we're just relying on the code which actually
tries to create or run files etc to do something sensible on
failure. Ideally, this is how we should handle stuff, rather than
trying to figure it out a priori.

=cut

# for now, we ignore these bits on Windows, but honour them on UNIX.
use CFX5::Config::def CFX5_IGNORE_PERMISSION_BITS => sub { $Config{windows_nt}; };

sub trust_file_bits {
  return not $Config{CFX5_IGNORE_PERMISSION_BITS};
}

=head2 execfile

True if the file can be used as an executable program.

=cut

sub execfile {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  # now, for an executable, we will fill in the .exe [NB not .bat or
  # .com, I'm too lazy!] if it's not there, as that's what the OS does
  # with executables.
  if (not -e $f and -e "$f.exe") {
    _debug("Appending .exe to $f");
    $f="$f.exe";
  }

  unless (test_e $f) {
    _error("$context does not exist");
    return 0;
  }
  if (test_d $f) {
    _error("$context is a directory!");
    return 0;
  }
  if (trust_file_bits()) {
    unless (-x $f) {
      _error("$context is not executable");
      return 0;
    }
  }
  return 1;
}

=head2 datafile

True if the file can be used as a data file (ie, read normally).

=cut

sub datafile {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  unless (test_e $f) {
    _error("$context does not exist");
    return 0;
  }
  if (test_d $f) {
    _error("$context is a directory!");
    return 0;
  }
  if (trust_file_bits()) {
    unless (test_r $f) {
      _error("$context cannot be read");
      return 0;
    }
  }
  return 1;
}

=head2 datafile_w

True if the file can be written as a data file. This is the case if
the directory containing it exists and is writable, and the file
itself is writable if it exists.

These are not the exact conditions for this, of course, but it assumes
that the program wanting to write the file will want to back up any
existing version.

=cut

sub datafile_w {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  if ((test_d $f)) {
    _error("$context is a directory");
    return 0;
  }
  if (trust_file_bits()) {
    if ((test_e $f and ! test_w $f)) {
      _error("$context exists and is unwritable");
      return 0;
    }
  }

  my @f=split_file($f);
  pop @f;

  my $d;
  if (scalar @f > 0) {
    $d=join_file(@f);
  } else {
    $d=".";
  }

  unless (test_e $d) {
    _error("Directory $d for $context does not exist");
    return 0;
  }
  if (trust_file_bits()) {
    unless (test_w $d) {
      _error("Directory $d for $context is not writable");
      return 0;
    }
  }

  return 1;
}

=head2 datadir

True if the directory can be accessed for reading (including listing of files
on UNIX, ie also has execute permission).

=cut

sub datadir {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  unless (test_e $f) {
    _error("$context does not exist.");
    return 0;
  }
  if (test_f $f) {
    _error("$context is a file!");
    return 0;
  }
  unless (test_d $f) {
    _error("$context is not a directory.");
    return 0;
  }
  if (trust_file_bits()) {
    unless (test_r $f) {
      _error("$context cannot be read");
      return 0;
    }
    if ($^O ne 'MSWin32') {
      unless (-x $f) {
        _error("$context does not have execute permission.");
        return 0;
      }
    }
  }
  
  return 1;
}

=head2 datadir_w

True if the directory can be accessed for reading (including listing of files
on UNIX, ie also has execute permission) and writing.

=cut

sub datadir_w {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  unless (test_e $f) {
    _error("$context does not exist.");
    return 0;
  }
  if (test_f $f) {
    _error("$context is file!");
    return 0;
  }
  unless (test_d $f) {
    _error("$context is not a directory.");
    return 0;
  }
  if (trust_file_bits()) {
    unless (test_r $f) {
      _error("$context cannot be read");
      return 0;
    }
    if ($^O ne 'MSWin32') {
      unless (-x $f) {
        _error("$context does not have execute permission.");
        return 0;
      }
    }
    unless (test_w $f) {
      _error("$context cannot be written to.");
      return 0;
    }
  }

  return 1;
}

=head2 datadir_cw

True if the directory can be accessed for reading (including listing
of files on UNIX, ie also has execute permission) and writing.  If the
directory does not exist, this function assumes it will be created by
the caller (in contrast to C<datadir_w>), and ensures that the parent
directory is writable.  If the parent directory does not exist, looks
up one more level, and so on and so forth.

=cut

sub datadir_cw {
  my $f=shift;
  my $context=shift;
  unless (defined $context) {
    $context=$f;
  }

  unless (defined $f) {
    internal_error("$context not defined.");
    return 0;
  }

  # Two choices.  Either it exists, or it doesn't ...
  if (test_e $f) {
    if (test_f $f) {
      _error("$context is file!");
      return 0;
    }
    unless (test_d $f) {
      _error("$context is not a directory.");
      return 0;
    }
    if (trust_file_bits()) {
      unless (test_r $f) {
        _error("$context cannot be read");
        return 0;
      }
      if ($^O ne 'MSWin32') {
        unless (-x $f) {
          _error("$context does not have execute permission.");
          return 0;
        }
      }
      unless (test_w $f) {
        _error("$context cannot be written to.");
        return 0;
      }
    }
  } else {
    # doesn't exist, so look for a parent which does, and apply
    # similar checks for that
    my @comps=split_file(fullpath($f));

    while (@comps) {
      # if this is a drive letter, we've had it.  Or have we?  We
      # can't do any more here, anyway ...
      last if $comps[$#comps] =~ m/^\w:/;

      my $nf=join_file(@comps);

      # if this is there, we've found something we can check
      last if (test_e $nf);
	
      # this doesn't exist at all, go up another level
      pop @comps;
    }

    _debug("Components of directory are: ", join(' -/- ',@comps));

    # what do we have left?
    if (!@comps) {
      # nothing
      _error("$context does not have an existing parent directory");
      return 0;
    } elsif ($^O eq 'MSWin32' and @comps==1 and $comps[0] =~ m/^\w:/) {
      # a bare drive letter; what do we do now?  We need to know if
      # the drive letter is valid, so try opening it.
      local *TDIR;
      if (opendir TDIR, $comps[0]) {
	# OK
	closedir TDIR;
      } else {
	# nope
	_error("$context references a non-existant drive");
	return 0;
      }
      # assume this is OK then
      return 1;
    } else {
      # OK, we've got a file or directory.  Test it.  How?  Well, we
      # need to ensure that it's a writable directory, so how about
      # datadir_w?
      my $nf=join_file(@comps);
      return datadir_w($nf,"Parent $nf of $context");
    }
  }

  return 1;
}


1;
