The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::Tester;
use Test::More qw(no_plan);
use User::pwent;
use Cwd;

use strict;
use warnings;
no warnings qw(once redefine); # stop complaints about getpwnam() changes

use_ok('Test::Unix::User');

# Create a User::pwent user
my $U = User::pwent->new();

$U->name('test');
$U->dir(getcwd());

# Override the version of getpwnam() in Test::Unix::User's namespace, and
# return our testing user if the user asked for is 'test', otherwise 
# return undef.
*Test::Unix::User::getpwnam = sub ($) { 
  if($_[0] eq 'test') {
    return $U;
  } else {
    return undef;
  }
};

# Get stat() info for the current directory
use File::stat;
my $sb = stat(getcwd());

# Things that should pass
check_test(sub { homedir_ok({ name => 'test' }, "'test' home directory"); },
  { ok => 1, name => "'test' home directory", }, "Test for home dir existence");

check_test(sub { homedir_ok({ name => 'test' }) },
  { ok => 1, name => "Home directory for user 'test' (name)", }, 
  "Test for home dir existence (1 arg form)");

check_test(sub { homedir_ok({ name => 'test', uid => $sb->uid,
                              gid => $sb->gid, perm => $sb->mode & 07777}); },
  { ok => 1, name => "Home directory for user 'test' (gid, name, perm, uid)", },
  "Test for home dir existence with all attributes");

# Get the current owner/group for the directory and make sure that they
# pass
my $owner = getpwuid($sb->uid)->name();
my $group = getgrgid($sb->gid);

check_test(sub { homedir_ok({ name => 'test', owner => $owner }); },
  { ok => 1, name => "Home directory for user 'test' (name, owner)", 
    diag => ''},
  "Test for home dir existence with owner");

check_test(sub { homedir_ok({ name => 'test', group => $group }); },
  { ok => 1, name => "Home directory for user 'test' (group, name)", },
  "Test for home dir existence with group");

# Find another valid owner/group, and make sure they fail
my $real_uid = $sb->uid;
my $real_gid = $sb->gid;
my($wrong_uid, $wrong_owner, $wrong_gid, $wrong_group);

for($wrong_uid = 0; $wrong_uid <= 32766; $wrong_uid++) {
  next if $wrong_uid == $real_uid;
  $wrong_owner = getpwuid($wrong_uid)->name();
  last if defined $wrong_owner;
}

for($wrong_gid = 0; $wrong_gid <= 32768; $wrong_gid++) {
  next if $wrong_gid == $real_gid;
  $wrong_group = getgrgid($wrong_gid);
  last if defined $wrong_group;
}

check_test(sub { homedir_ok({ name => 'test', owner => $wrong_owner }); },
  { ok => 0, name => "Home directory for user 'test' (name, owner)", 
    diag => "    Field: owner\n    expected: $wrong_owner\n         got: $owner", },
  "Test for home dir existence with wrong owner");

check_test(sub { homedir_ok({ name => 'test', group => $wrong_group }); },
  { ok => 0, name => "Home directory for user 'test' (group, name)",
    diag => "    Field: group\n    expected: $wrong_group\n         got: $group"
, },
  "Test for home dir existence with wrong group");


#
# Can safely bypass many of the specification checks.  They're duplicated
# in the tests for user_ok, and the code calls down to _check_spec().
#

# One test to verify that _check_spec() does the right thing
check_test(sub { homedir_ok(); },
  { ok => 0, name => 'homedir_ok()', 
    diag => '    homedir_ok() called with no arguments', }, 
  "homedir_ok(), no arguments");

# Make sure that bogus fields are caught
check_test(sub { homedir_ok({ name => 'test', foo => 'bar', }); },
  { ok => 0, name => "Home directory for user 'test' (foo, name)",
    diag => "    Invalid field 'foo' given" },
  "Test for bogus field in specification");

check_test(sub { homedir_ok({ name => 'test', uid => undef, }); },
  { ok => 0, name => "Home directory for user 'test' (name, uid)",
    diag => "    Empty field 'uid' given" },
  "Test for undefined field in specification");

check_test(sub { homedir_ok({ name => 'test', uid => '', }); },
  { ok => 0, name => "Home directory for user 'test' (name, uid)",
    diag => "    Empty field 'uid' given" },
  "Test for empty field in specification");

check_test(sub { homedir_ok({ name => 'nik' }); },
  { ok => 0, name => "Home directory for user 'nik' (name)",
    diag => "    User 'nik' does not exist" , },
  "Test that it fails correctly for non-existent users");

# Make sure it fails when the home directory isn't actually a directory
my $olddir = $U->dir;
$U->dir('Build.PL');

check_test(sub { homedir_ok({ name => 'test' }); },
  { ok => 0, name => "Home directory for user 'test' (name)",
    diag => "    Home directory 'Build.PL' for 'test' is not a directory" , },
  "Test that it fails correctly for non-existent home directories");

$U->dir($olddir);

# Make sure that things fail when permissions, uids and gids
my $correct_perm = $sb->mode & 07777;
my $funky_perm   = $correct_perm ^ 1;
check_test(sub { homedir_ok({ name => 'test', uid => $sb->uid,
                              gid => $sb->gid, perm => $funky_perm}); },
  { ok => 0, name => "Home directory for user 'test' (gid, name, perm, uid)", 
    diag => sprintf("    Field: perm\n    expected: %04o\n         got: %04o\n", $funky_perm, $correct_perm), },
  "Test that incorrect permissions generate an error");

my $correct_uid = $sb->uid;
my $funky_uid = $correct_uid == 0 ? $correct_uid + 1 : $correct_uid - 1;

check_test(sub { homedir_ok({ name => 'test', uid => $funky_uid,
                              gid => $sb->gid, perm => $correct_perm}); },
  { ok => 0, name => "Home directory for user 'test' (gid, name, perm, uid)",
    diag => "    Field: uid\n    expected: $funky_uid\n         got: $correct_uid\n", },
  "Test that incorrect uid generates an error");