File Coverage

blib/lib/Win32/CryptData.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Win32::CryptData;

use 5.006;
use strict;
use Carp;

use Win32;
use Win32::API '0.20';

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Win32::IPHelper ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
	'all' => [ qw( CryptProtectData CryptUnprotectData CRYPTPROTECT_PROMPT_ON_UNPROTECT CRYPTPROTECT_PROMPT_ON_PROTECT CRYPTPROTECT_PROMPT_STRONG CRYPTPROTECT_UI_FORBIDDEN CRYPTPROTECT_LOCAL_MACHINE CRYPTPROTECT_AUDIT CRYPTPROTECT_VERIFY_PROTECTION ) ],
	'flags' => [ qw( CRYPTPROTECT_PROMPT_ON_UNPROTECT CRYPTPROTECT_PROMPT_ON_PROTECT CRYPTPROTECT_PROMPT_STRONG CRYPTPROTECT_UI_FORBIDDEN CRYPTPROTECT_LOCAL_MACHINE CRYPTPROTECT_AUDIT CRYPTPROTECT_VERIFY_PROTECTION ) ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

our $VERSION = '0.02';

my $CryptProtectData = new Win32::API ('Crypt32', 'CryptProtectData', ['P', 'P', 'P', 'P', 'P', 'N', 'P'], 'N') or croak 'can\'t find CryptProtectData() function';
my $CryptUnprotectData = new Win32::API ('Crypt32', 'CryptUnprotectData', ['P', 'P', 'P', 'P', 'P', 'N', 'P'], 'N') or croak 'can\'t find CryptUnprotectData() function';
my $LocalFree = new Win32::API ('Kernel32', 'LocalFree', ['N'], 'N') or croak 'can\'t find LocalFree() function';

#############
# Constants #
#############
# $dwPromptFlags
use constant CRYPTPROTECT_PROMPT_ON_UNPROTECT => 0x1;
use constant CRYPTPROTECT_PROMPT_ON_PROTECT   => 0x2;
#use constant CRYPTPROTECT_PROMPT_RESERVED     => 0x4; # reserved, do not use.
use constant CRYPTPROTECT_PROMPT_STRONG       => 0x8;

# $dwFlags
use constant CRYPTPROTECT_UI_FORBIDDEN        => 0x1;
use constant CRYPTPROTECT_LOCAL_MACHINE       => 0x4;
use constant CRYPTPROTECT_AUDIT               => 0x10;
use constant CRYPTPROTECT_VERIFY_PROTECTION   => 0x40;

our $DEBUG = 0;

#################################
# PUBLIC Functions (exportable) #
#################################

#######################################################################
# Win32::CryptData::CryptProtectData()
#
# The CryptProtectData function performs encryption on the data in a
# DATA_BLOB structure. Typically, only a user with the same logon
# credential as the encrypter can decrypt the data. In addition, the
# encryption and decryption usually must be done on the same computer.
#
#######################################################################
# Usage:
#	$ret = CryptProtectData(\$pDataIn, \$szDataDescr, \$pOptionalEntropy, \$pvReserved, \%pPromptStruct, $dwFlags, \$pDataOut);
#
# Output:
#	$ret = 1 for success, undef for failure
#
# Input:
#	\$pDataIn = Pointer to the plaintext string to be encrypted
#	\$szDataDescr  = String with a readable description of the data to be encrypted
#	\$pOptionalEntropy = Pointer to a password or other additional entropy used to encrypt the data
#	\$pvReserved = reserved, must be set to undef
#	\%pPromptStruct = Pointer to a hash that provides information about where and when prompts are to be displayed
#		PromptFlags => one or more of the following values:
#			CRYPTPROTECT_PROMPT_ON_PROTECT = This flag is used to provide the prompt for the protect phase
#			CRYPTPROTECT_PROMPT_ON_UNPROTECT = This flag can be combined with CRYPTPROTECT_PROMPT_ON_PROTECT to enforce the UI (user interface) policy of the caller
#			CRYPTPROTECT_PROMPT_STRONG = This flag forces user to provide an encryption password
#		hwndApp => handle of the parent window if needed modal behaviour
#		Prompt => caption for the prompt
#	$dwFlags = The following flag values are defined:
#		CRYPTPROTECT_LOCAL_MACHINE = When this flag is set, it associates the data encrypted with the current computer instead of with an individual user
#		CRYPTPROTECT_UI_FORBIDDEN = This flag is used for remote situations where presenting a user interface (UI) is not an option
#		CRYPTPROTECT_AUDIT = This flag generates an audit on protect and unprotect operations
#		CRYPTPROTECT_VERIFY_PROTECTION = This flag verifies the protection of a protected string
#
# Output:
#	\$pDataOut = Pointer to the string that receives the encrypted data
#
#######################################################################
# function CryptProtectData
#
#	The CryptProtectData function performs encryption on the data in a DATA_BLOB structure
#
#	BOOL WINAPI CryptProtectData(
#		DATA_BLOB* pDataIn,
#		LPCWSTR szDataDescr,
#		DATA_BLOB* pOptionalEntropy,
#		PVOID pvReserved,
#		CRYPTPROTECT_PROMPTSTRUCT* pPromptStruct,
#		DWORD dwFlags,
#		DATA_BLOB* pDataOut
#	);
#
#######################################################################
sub CryptProtectData
{
	if(scalar(@_) ne 7)
	{
		croak 'Usage: CryptProtectData(\\\$pDataIn, \\\$szDataDescr, \\\$pOptionalEntropy, \\\$pvReserved, \\\%pPromptStruct, \$dwFlags, \\\$pDataOut)';
	}

	my $DataIn = shift;
	my $szDataDescr = _ToUnicodeSz(${shift()});
	my $OptionalEntropy = shift;
	my $pvReserved = pack("L", shift);
	my %PromptStruct = %{ shift() };

	my $dwFlags = shift || 0;

	my $DataOut = shift;

	my $pDataOut = pack("LL", 0x0, 0x0);

	my $pDataIn = pack("LL", length($$DataIn), unpack("L!", pack("P", $$DataIn)));
	my $pOptionalEntropy = pack("LL", length($$OptionalEntropy)+1, unpack("L!", pack("P", $$OptionalEntropy)));
	my $szPrompt = _ToUnicodeSz($PromptStruct{'Prompt'});
	my $pPromptStruct = pack("L4",
							 16,
							 $PromptStruct{'PromptFlags'} || 0,
							 $PromptStruct{'hwndApp'} || 0,
							 unpack("L!", pack("P", $szPrompt))
	);

	if($CryptProtectData->Call($pDataIn, $szDataDescr, $pOptionalEntropy, $pvReserved, $pPromptStruct, $dwFlags, $pDataOut))
	{
		my($len, $ptr) = unpack("LL", $pDataOut);
		$$DataOut = unpack('P'.$len, pack('L!', $ptr));

		$LocalFree->Call($ptr) and warn "Cannot LocalFree() pDataOut buffer: $^E";

		return 1;
	}
}

#######################################################################
# Win32::CryptData::CryptUnprotectData()
#
# The CryptUnprotectData function decrypts and does an integrity check
# of the data in a DATA_BLOB structure. Usually, only a user with the
# same logon credentials as the encrypter can decrypt the data.
#
#######################################################################
# Usage:
#	$ret = CryptUnprotectData(\$pDataIn, \$szDataDescr, \$pOptionalEntropy, \$pvReserved, \%pPromptStruct, $dwFlags, \$pDataOut);
#
# Output:
#	$ret = 1 for success, undef for failure
#
# Input:
#	\$pDataIn = Pointer to the plaintext string to be decrypted
#	\$pOptionalEntropy = Pointer to a password or other additional entropy used to encrypt the data
#	\$pvReserved = reserved, must be set to undef
#	\%pPromptStruct = Pointer to a hash that provides information about where and when prompts are to be displayed
#		PromptFlags => one or more of the following values:
#			CRYPTPROTECT_PROMPT_ON_PROTECT = This flag is used to provide the prompt for the protect phase
#			CRYPTPROTECT_PROMPT_ON_UNPROTECT = This flag can be combined with CRYPTPROTECT_PROMPT_ON_PROTECT to enforce the UI (user interface) policy of the caller
#			CRYPTPROTECT_PROMPT_STRONG = This flag forces user to provide an encryption password
#		hwndApp => handle of the parent window if needed modal behaviour
#		Prompt => caption for the prompt
#	$dwFlags = The following flag values are defined:
#		CRYPTPROTECT_UI_FORBIDDEN = This flag is used for remote situations where presenting a user interface (UI) is not an option
#
# Output:
#	\$szDataDescr  = String with a readable description of the data to be encrypted
#	\$pDataOut = Pointer to the string that receives the encrypted data
#
#######################################################################
# function CryptUnprotectData
#
#	The CryptUnprotectData function decrypts and does an integrity check of the data in a DATA_BLOB structure
#
#	BOOL WINAPI CryptUnprotectData(
#		DATA_BLOB* pDataIn,
#		LPWSTR* ppszDataDescr,
#		DATA_BLOB* pOptionalEntropy,
#		PVOID pvReserved,
#		CRYPTPROTECT_PROMPTSTRUCT* pPromptStruct,
#		DWORD dwFlags,
#		DATA_BLOB* pDataOut
#	);
#
#######################################################################
sub CryptUnprotectData
{
	if(scalar(@_) ne 7)
	{
		croak 'Usage: CryptUnprotectData(\\\$pDataIn, \\\$szDataDescr, \\\$pOptionalEntropy, \\\$pvReserved, \\\$pPromptStruct, \$dwFlags, \\\$pDataOut)';
	}

	my $DataIn = shift;
	my $szDataDescr = shift;
	my $pszDataDescr = pack('L', 0);
	my $OptionalEntropy = shift;
	my $pvReserved = pack('L', shift);
	my %PromptStruct = %{ shift() };

	my $dwFlags = shift || 0;

	my $DataOut = shift;

	my $pDataOut = pack('LL', 0, 0);

	my $pDataIn = pack('LL', length($$DataIn)+1, unpack('L!', pack('P', $$DataIn)));
	my $pOptionalEntropy = pack('LL', length($$OptionalEntropy)+1, unpack('L!', pack('P', $$OptionalEntropy)));
	my $szPrompt = _ToUnicodeSz($PromptStruct{'Prompt'});
	my $pPromptStruct = pack('L4',
							 16,
							 $PromptStruct{'PromptFlags'} || 0,
							 $PromptStruct{'hwndApp'} || 0,
							 unpack('L!', pack('P', $szPrompt))
	);

	if($CryptUnprotectData->Call($pDataIn, $pszDataDescr, $pOptionalEntropy, $pvReserved, $pPromptStruct, $dwFlags, $pDataOut))
	{
		my($len, $ptr) = unpack('LL', $pDataOut);
		$$DataOut = unpack('P'.$len, pack('L!', $ptr));

		$LocalFree->Call($ptr) and warn "Cannot LocalFree() pDataOut buffer: $^E";

		my $i = 0;
		do {
			$i += 2;
			$$szDataDescr = unpack('P'.$i, $pszDataDescr);
		}
		while(substr($$szDataDescr, -2) ne "\0\0");

		$$szDataDescr = _FromUnicode($$szDataDescr);
		$LocalFree->Call(unpack('L', $pszDataDescr)) and warn "Cannot LocalFree() pszDataDescr buffer: $^E";

		return 1;
	}
}

#######################################################################
# WCHAR = _ToUnicodeChar(string)
# converts a perl string in a 16-bit (pseudo) unicode string
#######################################################################
sub _ToUnicodeChar
{
	my $string = shift or return(undef);

	$string =~ s/(.)/$1\x00/sg;

	return $string;
}


#######################################################################
# WSTR = _ToUnicodeSz(string)
# converts a perl string in a null-terminated 16-bit (pseudo) unicode string
#######################################################################
sub _ToUnicodeSz
{
	my $string = shift or return(undef);

	return _ToUnicodeChar($string."\x00");
}


#######################################################################
# string = _FromUnicode(WSTR)
# converts a null-terminated 16-bit unicode string into a regular perl string
#######################################################################
sub _FromUnicode
{
	my $string = shift or return(undef);

	$string = unpack("Z*", pack( "C*", unpack("S*", $string)));

	return($string);
}


1;
__END__