The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/perl -wT
use strict;
use lib 'blib/lib';
use lib 'blib/arch';

# These tests are intended to be executed with set-uid privileges.

use Test;
BEGIN {
	if ($> == 0 or $< == 0) {
		print "1..0 # Skipped, this file must not run directly as root.\n";
		exit 0;
	} elsif ($< == $>) {
		print "1..0 # Skipped, this file must run setuid.\n";
		exit 0;
	}
	plan tests => 18;
}

use Proc::UID qw(
	geteuid getruid getsuid $EUID $RUID $SUID
	drop_uid_temp drop_uid_perm restore_uid
);

# Basic sanity checking.
ok(1);	# Loaded module.
ok($<==$RUID,1,'$< is not $RUID');
ok($>==$EUID,1,'$> is not $EUID');
ok($<==getruid(),1,'$< and getruid() disagree');
ok($>==geteuid(),1,'$> and geteuid() disagree');
ok($SUID,geteuid(),"\$SUID and geteuid() are not same at startup ($SUID $EUID).");

# Find a gid that we can't change to.
my $bad_uid = 0;
while ($bad_uid == $EUID or $bad_uid == $RUID or $bad_uid == $SUID) {
	$bad_uid++;
}

# Let's try to change to a bad uid.
eval {drop_uid_temp($bad_uid);};
ok($@,qr/Could not/,"Appeared to drop privs to $bad_uid");

# Drop privs temporarily.
ok(eval {drop_uid_temp($RUID); "ok";},"ok","Could not drop UID temporarily.");
ok($RUID,$EUID,"New UID not assumed");
ok($EUID==$>,1,'$> appears not to have been updated.');

# Restore privs
ok(eval {restore_uid(); "ok";},"ok","Could not restore UID");
ok($EUID,$SUID,"Did not restore old UID.");
ok($EUID==$>,1,'$> appears not to have been updated.');

# Drops privs permanently.
ok(eval {drop_uid_perm($RUID); "ok";},"ok","Could not drop GID permanently.");
ok($RUID,$SUID,"Real and saved UIDs do not match.");
ok($RUID,$EUID,"Real and effective UIDs do not match.");
ok($<==$RUID,1,'$< and $RUID disagree');
ok($>==$EUID,1,'$> and $EUID disagree');