The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#############################################################################
#
# Win32::Security::Raw - low-level access Win32 Security API calls
#
# Author: Toby Ovod-Everett
#
#############################################################################
# Copyright 2003, 2004 Toby Ovod-Everett.  All rights reserved
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# For comments, questions, bugs or general interest, feel free to
# contact Toby Ovod-Everett at toby@ovod-everett.org
#############################################################################

=head1 NAME

C<Win32::Security::Raw> - low-level access Win32 Security API calls

=head1 SYNOPSIS

	use Win32::Security::Raw;

=head1 DESCRIPTION

This module provides access to a limited number of Win32 Security API calls.
As I have need for other functions I will add them to the module.  If anyone
has suggestions, feel free to ask - I will be quite happy to extend this
module.


=head2 Installation instructions

This installs as part of C<Win32-Security>.  See 
C<Win32::Security::NamedObject> for more information.

It depends upon the C<Win32::API> and C<Data::BitMask> modules, which
should be installable via PPM or available on CPAN.

=cut

use Carp;
use Win32::API;
use Data::BitMask '0.13';

use strict;

package Win32::Security::Raw;

=head1 Function Reference

=head2 C<AdjustTokenPrivileges>

=cut

{
my $call;
sub AdjustTokenPrivileges {
	my($TokenHandle, $DisableAllPrivileges, $NewState) = @_;

	ref($NewState) eq 'ARRAY' or Carp::croak("AdjustTokenPrivileges requires array ref for NewState.");
	scalar(@{$NewState}) >= 1 or Carp::croak("AdjustTokenPrivileges requires at least one element for NewState.");
	my $pNewState = pack('V', scalar(@{$NewState}));
	foreach my $laa (@{$NewState}) {
		ref($laa) eq 'ARRAY' or Carp::croak("AdjustTokenPrivileges requires all elements of NewState to be array refs.");
		scalar(@{$laa}) == 2 or Carp::croak("AdjustTokenPrivileges requires all elements of NewState to be array refs with two elements.");
		length($laa->[0]) == 8 or Carp::croak("AdjustTokenPrivileges requires all LUID values to be 8 bytes.");
		$pNewState .= $laa->[0].pack('V', &Win32::Security::LUID_ATTRIBUTES->build_mask($laa->[1]));
	}

	my $BufferLength = length($pNewState);
	my $pPreviousState = ("\0" x $BufferLength);
	my $pReturnLength = pack('V', $BufferLength);

	$call ||= Win32::API->new('advapi32',
				'AdjustTokenPrivileges', [qw(I I P I P P)], 'I') or
			Carp::croak("Unable to connect to AdjustTokenPrivileges.");

	$call->Call($TokenHandle, $DisableAllPrivileges, $pNewState, $BufferLength, $pPreviousState, $pReturnLength);
	my $error = Win32::GetLastError();
	$error and Carp::croak(&_format_error('AdjustTokenPrivileges', $error));

	my $PreviousCount = unpack('V', $pPreviousState);
	my $PreviousState = [];
	foreach my $i (0..$PreviousCount-1) {
		my $Luid = substr($pPreviousState, $i*12+4, 8);
		my $Attributes = &Win32::Security::LUID_ATTRIBUTES->break_mask(unpack('V', substr($pPreviousState, $i*12+12, 4)));
		push(@{$PreviousState}, [$Luid, $Attributes]);
	}

	return $PreviousState;
}
}


=head2 C<CopyMemory_Read>

Uses C<RtlMoveMemory> to read an arbitrary memory location.  You should pass a
pointer in the form of a Perl integer and the number of bytes to read from that
location.  The function will return the data read in a Perl string.

=cut

{
my $call;
sub CopyMemory_Read {
	my($pSource, $Length) = @_;

	$call ||= Win32::API->new('kernel32',
				'RtlMoveMemory', [qw(P I I)], 'V') or
			Carp::croak("Unable to connect to RtlMoveMemory.");

	my $Destination = "\0"x$Length;
	$call->Call($Destination, $pSource, $Length);
	return $Destination;
}
}


=head2 C<CopyMemory_Write>

Uses C<RtlMoveMemory> to write to an arbitrary memory location.  You should pass 
a string that will be copied and a pointer in the form of a Perl integer.  The 
caller is responsible for ensuring that the data to be written will not overrun 
the memory location.

=cut

{
my $call;
sub CopyMemory_Write {
	my($string, $pDest) = @_;

	$call ||= Win32::API->new('kernel32',
				'RtlMoveMemory', [qw(I P I)], 'V') or
			Carp::croak("Unable to connect to RtlMoveMemory.");
	$call->Call($pDest, $string, length($string));
}
}


=head2 C<GetCurrentProcess>

Returns a handle to the C<CurrentProcess> as an integer.

=cut

{
my $call;
sub GetCurrentProcess {
	$call ||= Win32::API->new('kernel32',
				'GetCurrentProcess', [], 'I') or
			Carp::croak("Unable to connect to GetCurrentProcess.");

	$call->Call();
}
}


=head2 C<GetAclInformation>

This expects a pointer to an ACL and an C<AclInformationClass> value (i.e. 
C<'AclSizeInformation'> or C<'AclRevisionInformation'>).  It returns the 
approriate data for the C<AclInformationClass> value (the C<AclRevision> in the 
case of C<AclRevisionInformation>, the C<AceCount>, C<AclBytesInUse>, and 
C<AclBytesFree> in the case of C<AclSizeInformation>).

=cut

{
my $call;
sub GetAclInformation {
	my($pAcl, $dwAclInformationClass) = @_;

	$call ||= Win32::API->new('advapi32',
				'GetAclInformation', [qw(I P I I)], 'I') or
			Carp::croak("Unable to connect to GetAclInformation.");

	my $structures = {
		AclRevisionInformation  => 'V',
		AclSizeInformation => 'VVV'
	};

	my($pAclInformation) = (pack($structures->{$dwAclInformationClass}));

	$call->Call($pAcl, $pAclInformation, length($pAclInformation),
				&Win32::Security::ACL_INFORMATION_CLASS->build_mask($dwAclInformationClass)) or
			Carp::croak(&_format_error('GetAclInformation'));

	my(@retvals) = unpack($structures->{$dwAclInformationClass}, $pAclInformation);

	return(@retvals);
}
}


=head2 C<GetLengthSid>

This accepts a pointer to a SID as an integer and returns the length.

=cut

{
my $call;
sub GetLengthSid {
	my($pSid) = @_;

	$call ||= Win32::API->new('advapi32',
				'GetLengthSid', [qw(I)], 'I') or
			Carp::croak("Unable to connect to GetLengthSid.");

	return $call->Call($pSid);
}
}


=head2 C<GetNamedSecurityInfo>

This expects an object name (i.e. a path to a file, registry key, etc.), an 
object type (i.e. C<'SE_FILE_OBJECT'>), and a C<SECURITY_INFORMATION> mask (i.e. 
C<'OWNER_SECURITY_INFORMATION|DACL_SECURITY_INFORMATION'>).  It returns pointers 
(as integers) to C<sidOwner>, C<sidGroup>, C<Dacl>, C<Sacl>, and the 
C<SecurityDescriptor>.  Some of these may be null pointers.

=cut

{
my $call;
sub GetNamedSecurityInfo {
	my($pObjectName, $ObjectType, $SecurityInfo) = @_;

	$call ||= Win32::API->new('advapi32',
				'GetNamedSecurityInfo', [qw(P I I P P P P P)], 'I') or
			Carp::croak("Unable to connect to GetNamedSecurityInfo.");

	$ObjectType = &Win32::Security::SE_OBJECT_TYPE->build_mask($ObjectType);
	$SecurityInfo = &Win32::Security::SECURITY_INFORMATION->build_mask($SecurityInfo);

	my($ppsidOwner, $ppsidGroup, $ppDacl, $ppSacl, $ppSecurityDescriptor) = ("\0"x4) x 5;

	my $retval = $call->Call($pObjectName, int($ObjectType),
			$SecurityInfo, $ppsidOwner, $ppsidGroup, $ppDacl, $ppSacl, $ppSecurityDescriptor);

	$retval and Carp::croak(&_format_error('GetNamedSecurityInfo', $retval));

	foreach ($ppsidOwner, $ppsidGroup, $ppDacl, $ppSacl, $ppSecurityDescriptor) {
		$_ = unpack("V", $_);
	}

	return($ppsidOwner, $ppsidGroup, $ppDacl, $ppSacl, $ppSecurityDescriptor);
}
}


=head2 C<GetSecurityDescriptorControl>

This expects a pointer to a C<SecurityDescriptor>.  It returns the
C<Data::BitMask::break_mask> form for the
C<SECURITY_DESCRIPTOR_CONTROL> mask.

=cut

{
my $call;
sub GetSecurityDescriptorControl {
	my($pSecurityDescriptor) = @_;

	$call ||= Win32::API->new('advapi32',
				'GetSecurityDescriptorControl', [qw(I P P)], 'I') or
			Carp::croak("Unable to connect to GetSecurityDescriptorControl.");

	my($pControl, $lpdwRevision) = ("\0"x2, "\0"x4);

	$call->Call($pSecurityDescriptor, $pControl, $lpdwRevision) or
			Carp::croak(&_format_error('GetSecurityDescriptorControl'));

	$pControl = &Win32::Security::SECURITY_DESCRIPTOR_CONTROL->break_mask(unpack("S", $pControl));
	$lpdwRevision = unpack("V", $lpdwRevision);

	return($pControl, $lpdwRevision);
}
}


=head2 C<InitializeSecurityDescriptor>

Calls C<InitializeSecurityDescriptor> on the passed pointer.  C<dwRevision> is
optional - if omitted, revision 1 is used.  Dies if the call fails.

=cut

{
my $call;
sub InitializeSecurityDescriptor {
	my($pSecurityDescriptor, $dwRevision) = @_;

	$dwRevision = 1 unless defined $dwRevision;

	$call ||= Win32::API->new('advapi32',
				'InitializeSecurityDescriptor', [qw(I I)], 'I') or
			Carp::croak("Unable to connect to InitializeSecurityDescriptor.");

	$call->Call($pSecurityDescriptor, $dwRevision) or Carp::croak("Unable to InitializeSecurityDescriptor $pSecurityDescriptor.");
}
}


=head2 C<LocalAlloc>

Calls C<LocalAlloc> with the passed C<uFlags> and C<size>.  It returns the 
pointer, but dies if a null pointer is returned from the call.  The C<uFlags> 
parameter can be passed as either an integer or as legal C<LMEM_FLAGS>.

=cut

{
my $call;
sub LocalAlloc {
	my($uFlags, $uBytes) = @_;

	$uFlags = &Win32::Security::LMEM_FLAGS->build_mask($uFlags);

	$call ||= Win32::API->new('kernel32',
				'LocalAlloc', [qw(I I)], 'I') or
			Carp::croak("Unable to connect to LocalAlloc.");

	my $ptr = $call->Call($uFlags, $uBytes);
	$ptr or Carp::croak("Unable to LocalAlloc $uBytes.");
	return $ptr;
}
}


=head2 C<LocalFree>

Calls C<LocalFree> on the passed pointer.  The passed pointer should be in the
form of a Perl integer.

=cut

{
my $call;
sub LocalFree {
	my($pObject) = @_;

	$call ||= Win32::API->new('kernel32',
				'LocalFree', [qw(I)], 'I') or
			Carp::croak("Unable to connect to LocalFree.");

	$call->Call($pObject);
}
}


=head2 C<LookupPrivilegeValue>

Pass C<SystemName> (undef permitted) and a privilege C<Name> (i.e. 
C<SeRestorePrivilege>).  Returns the C<Luid>.

=cut

{
my $call;
sub LookupPrivilegeValue {
	my($lpSystemName, $lpName) = @_;

	my($lpLuid) = ("\0"x8);

	$call ||= Win32::API->new('advapi32',
				'LookupPrivilegeValue', [qw(P P P)], 'I') or
			Carp::croak("Unable to connect to LookupPrivilegeValue.");

	$call->Call($lpSystemName, $lpName, $lpLuid) or
			Carp::croak(&_format_error('LookupPrivilegeValue'));

	return $lpLuid;
}
}


=head2 C<OpenProcessToken>

Pass C<ProcessHandle> and C<DesiredAccess> (C<TokenRights>).  Returns 
C<TokenHandle>.

=cut

{
my $call;
sub OpenProcessToken {
	my($ProcessHandle, $DesiredAccess) = @_;

	$DesiredAccess = &Win32::Security::TokenRights->build_mask($DesiredAccess);

	my($TokenHandle) = ("\0"x4);

	$call ||= Win32::API->new('advapi32',
				'OpenProcessToken', [qw(I I P)], 'I') or
			Carp::croak("Unable to connect to OpenProcessToken.");

	$call->Call($ProcessHandle, $DesiredAccess, $TokenHandle) or
			Carp::croak(&_format_error('OpenProcessToken'));

	$TokenHandle = unpack("V", $TokenHandle);

	return $TokenHandle;
}
}


=head2 C<SetFileSecurity>

Pass C<FileName>, C<SecurityInfo>, and C<SecurityDescriptor>.  Useful for 
setting permissions without propagating inheritable ACEs.

=cut

{
my $call;
my $os2k;
sub SetFileSecurity {
	my($pFileName, $SecurityInfo, $pSecurityDescriptor) = @_;

	$call ||= Win32::API->new('advapi32',
				'SetFileSecurity', [qw(P I I)], 'I') or
			Carp::croak("Unable to connect to SetFileSecurity.");

	$SecurityInfo = &Win32::Security::SECURITY_INFORMATION->build_mask($SecurityInfo);

	unless (defined($os2k)) {
		my(@osver) = Win32::GetOSVersion();
		$os2k = ($osver[4] == 2 && $osver[1] >= 5);
	}

	if (!$os2k && scalar(grep(/PROTECTED/, keys %{&Win32::Security::SECURITY_INFORMATION->break_mask($SecurityInfo)})) ) {
		Carp::croak("Use of PROTECTED SECURITY_INFORMATION constant on a non Win2K or greater OS.");
	}

	$call->Call($pFileName, $SecurityInfo, $pSecurityDescriptor) or
			Carp::croak(&_format_error('SetFileSecurity'));
}
}



=head2 C<SetNamedSecurityInfo>

This expects an object name (i.e. a path to a file, registry key, etc.), an 
object type (i.e. C<'SE_FILE_OBJECT'>), and a C<SECURITY_INFORMATION> mask (i.e. 
C<'OWNER_SECURITY_INFORMATION|DACL_SECURITY_INFORMATION'>), and pointers (as 
integers) to C<sidOwner>, C<sidGroup>, C<Dacl>, and C<Sacl>.  These may be null 
pointers if they are not referenced in the C<SECURITY_INFORMATION> mask.

=cut

{
my $call;
my $os2k;
sub SetNamedSecurityInfo {
	my($pObjectName, $ObjectType, $SecurityInfo, $psidOwner, $psidGroup, $pDacl, $pSacl) = @_;

	$call ||= Win32::API->new('advapi32',
				'SetNamedSecurityInfo', [qw(P I I P P P P)], 'I') or
			Carp::croak("Unable to connect to SetNamedSecurityInfo.");

	$ObjectType = &Win32::Security::SE_OBJECT_TYPE->build_mask($ObjectType);
	$SecurityInfo = &Win32::Security::SECURITY_INFORMATION->build_mask($SecurityInfo);

	unless (defined($os2k)) {
		my(@osver) = Win32::GetOSVersion();
		$os2k = ($osver[4] == 2 && $osver[1] >= 5);
	}

	if (!$os2k && scalar(grep(/PROTECTED/, keys %{&Win32::Security::SECURITY_INFORMATION->break_mask($SecurityInfo)})) ) {
		Carp::croak("Use of PROTECTED SECURITY_INFORMATION constant on a non Win2K or greater OS.");
	}

	my $retval;
	{
		local $^W = 0; #Turn off warnings about uninitialized values . . .
		$retval = $call->Call($pObjectName, int($ObjectType),
				$SecurityInfo, $psidOwner, $psidGroup, $pDacl, $pSacl);
	}

	$retval and Carp::croak(&_format_error('SetNamedSecurityInfo', $retval));
}
}


=head2 C<SetSecurityDescriptorDacl>

Calls C<SetSecurityDescriptorDacl>.  Expects a pointer to a 
C<SecurityDescriptor>, C<DaclPresent>, C<Dacl>, and C<DaclDefaulted>.  Dies if 
the call fails.

=cut

{
my $call;
sub SetSecurityDescriptorDacl {
	my($pSecurityDescriptor, $bDaclPresent, $pDacl, $bDaclDefaulted) = @_;

	$call ||= Win32::API->new('advapi32',
				'SetSecurityDescriptorDacl', [qw(I I I I)], 'I') or
			Carp::croak("Unable to connect to SetSecurityDescriptorDacl.");

	$call->Call($pSecurityDescriptor, $bDaclPresent, $pDacl, $bDaclDefaulted) or Carp::croak("Unable to SetSecurityDescriptorDacl.");
}
}



sub _format_error {
	my($func, $retval) = @_;

	(my $msg = $func.": ".Win32::FormatMessage($retval || Win32::GetLastError()))
			=~ s/[\r\n]+$//;
	return $msg;
}



package Win32::Security;

=head1 C<Data::BitMask> Objects

The objects are accessed via class methods on C<Win32::Security>.  The
C<Data::BitMask> objects are created by the first call and lexically cached.

=cut

=head2 &Win32::Security::SE_OBJECT_TYPE

Win32 constants for C<SE_OBJECT_TYPE>, along with the following aliases:

=over 4

=item *

C<FILE> (C<SE_FILE_OBJECT>)

=item *

C<SERVICE> (C<SE_SERVICE>)

=item *

C<PRINTER> (C<SE_PRINTER>)

=item *

C<REG> (C<SE_REGISTRY_KEY>)

=item *

C<REGISTRY> (C<SE_REGISTRY_KEY>)

=item *

C<SHARE> (C<SE_LMSHARE>)

=back

=cut

{
my $cache;
sub SE_OBJECT_TYPE {
	$cache ||= Data::BitMask->new(
			SE_UNKNOWN_OBJECT_TYPE =>     0,
			SE_FILE_OBJECT =>             1,
			SE_SERVICE =>                 2,
			SE_PRINTER =>                 3,
			SE_REGISTRY_KEY =>            4,
			SE_LMSHARE =>                 5,
			SE_KERNEL_OBJECT =>           6,
			SE_WINDOW_OBJECT =>           7,
			SE_DS_OBJECT =>               8,
			SE_DS_OBJECT_ALL =>           9,
			SE_PROVIDER_DEFINED_OBJECT => 10,
			FILE =>                       1,
			SERVICE =>                    2,
			PRINTER =>                    3,
			REG =>                        4,
			REGISTRY =>                   4,
			SHARE =>                      5,
		);
}
}

=head2 &Win32::Security::SECURITY_INFORMATION

=cut

{
my $cache;
sub SECURITY_INFORMATION {
	$cache ||= Data::BitMask->new(
			OWNER_SECURITY_INFORMATION =>                      0x1,
			GROUP_SECURITY_INFORMATION =>                      0x2,
			DACL_SECURITY_INFORMATION =>                       0x4,
			SACL_SECURITY_INFORMATION =>                       0x8,
			UNPROTECTED_SACL_SECURITY_INFORMATION =>    0x10000000,
			UNPROTECTED_DACL_SECURITY_INFORMATION =>    0x20000000,
			PROTECTED_SACL_SECURITY_INFORMATION =>      0x40000000,
			PROTECTED_DACL_SECURITY_INFORMATION =>      0x80000000,
		);
}
}

=head2 &Win32::Security::SECURITY_DESCRIPTOR_CONTROL

=cut

{
my $cache;
sub SECURITY_DESCRIPTOR_CONTROL {
	$cache ||= Data::BitMask->new(
			SE_OWNER_DEFAULTED =>                0x0001,
			SE_GROUP_DEFAULTED =>                0x0002,
			SE_DACL_PRESENT =>                   0x0004,
			SE_DACL_DEFAULTED =>                 0x0008,
			SE_SACL_PRESENT =>                   0x0010,
			SE_SACL_DEFAULTED =>                 0x0020,
			SE_DACL_AUTO_INHERIT_REQ =>          0x0100,
			SE_SACL_AUTO_INHERIT_REQ =>          0x0200,
			SE_DACL_AUTO_INHERITED =>            0x0400,
			SE_SACL_AUTO_INHERITED =>            0x0800,
			SE_DACL_PROTECTED =>                 0x1000,
			SE_SACL_PROTECTED =>                 0x2000,
			SE_SELF_RELATIVE =>                  0x8000,
		);
}
}

=head2 &Win32::Security::ACL_INFORMATION_CLASS

=cut

{
my $cache;
sub ACL_INFORMATION_CLASS {
	$cache ||= Data::BitMask->new(
			AclRevisionInformation  => 1,
			AclSizeInformation      => 2,
		);
}
}

=head2 &Win32::Security::TokenRights

=cut

{
my $cache;
sub TokenRights {
	unless ($cache) {
		$cache = Data::BitMask->new(
				TOKEN_ASSIGN_PRIMARY    => 0x00000001,
				TOKEN_DUPLICATE         => 0x00000002,
				TOKEN_IMPERSONATE       => 0x00000004,
				TOKEN_QUERY             => 0x00000008,
				TOKEN_QUERY_SOURCE      => 0x00000010,
				TOKEN_ADJUST_PRIVILEGES => 0x00000020,
				TOKEN_ADJUST_GROUPS     => 0x00000040,
				TOKEN_ADJUST_DEFAULT    => 0x00000080,
				TOKEN_ADJUST_SESSIONID  => 0x00000100,

				DELETE                  => 0x00010000,
				READ_CONTROL            => 0x00020000,
				WRITE_DAC               => 0x00040000,
				WRITE_OWNER             => 0x00080000,

				ACCESS_SYSTEM_SECURITY  => 0x01000000,

				STANDARD_RIGHTS_READ    => 0x00020000,
				STANDARD_RIGHTS_WRITE   => 0x00020000,
				STANDARD_RIGHTS_EXECUTE => 0x00020000,
			);

		$cache->add_constants(
				TOKEN_EXECUTE => $cache->build_mask('STANDARD_RIGHTS_EXECUTE TOKEN_IMPERSONATE'),
				TOKEN_READ =>    $cache->build_mask('STANDARD_RIGHTS_READ TOKEN_QUERY'),
				TOKEN_WRITE =>   $cache->build_mask('STANDARD_RIGHTS_WRITE TOKEN_ADJUST_PRIVILEGES TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT'),
				TOKEN_ALL_ACCESS => $cache->build_mask('ACCESS_SYSTEM_SECURITY') | 0x000F01FF,
			);
	}
	return $cache;
}
}


=head2 &Win32::Security::LUID_ATTRIBUTES

=cut

{
my $cache;
sub LUID_ATTRIBUTES {
	$cache ||= Data::BitMask->new(
			SE_PRIVILEGE_USED_FOR_ACCESS    => 0x0000,
			SE_PRIVILEGE_ENABLED_BY_DEFAULT => 0x0001,
			SE_PRIVILEGE_ENABLED            => 0x0002,
	);
}
}


=head2 &Win32::Security::LMEM_FLAGS

=cut

{
my $cache;
sub LMEM_FLAGS {
	unless ($cache) {

		$cache = Data::BitMask->new(
				LMEM_FIXED          => 0x0000,
				LMEM_MOVEABLE       => 0x0002,
				LMEM_NOCOMPACT      => 0x0010,
				LMEM_NODISCARD      => 0x0020,
				LMEM_ZEROINIT       => 0x0040,
				LMEM_MODIFY         => 0x0080,
				LMEM_DISCARDABLE    => 0x0F00,
				LMEM_VALID_FLAGS    => 0x0F72,
				LMEM_INVALID_HANDLE => 0x8000,
			);

		$cache->add_constants(
				LHND        => $cache->build_mask('LMEM_MOVEABLE LMEM_ZEROINIT'),
				LPTR        => $cache->build_mask('LMEM_FIXED LMEM_ZEROINIT'),
				NONZEROLHND => $cache->build_mask('LMEM_MOVEABLE'),
				NONZEROLPTR => $cache->build_mask('LMEM_FIXED'),
			);
	}
	return $cache;
}
}


=head1 AUTHOR

Toby Ovod-Everett, toby@ovod-everett.org

=cut

1;