APIRegistry/test.pl - metacpan.org

#!/usr/bin/perl -w
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..211\n"; }
END {print "not ok 1\n" unless $loaded;}
use Win32API::Registry qw(:ALL);
$loaded = 1;
print "ok 1\n";

######################### End of black magic.

BEGIN { eval "use Win32API::Registry qw(:SE_);" }

$|= 1   if  $Debug= ( -t STDIN ) != ( -t STDOUT );

$zero= 0;	# Change to 0 when RegEnumKeyExA() and RegEnumValueA()
		# handle ERROR_MORE_DATA better!

$ok= RegQueryInfoKey( HKEY_LOCAL_MACHINE, $class, $clen=0, [],
  $nkeys, $xkey, $xclass, $nvals, $xval, $xdata, $xsec, $time );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
$Debug  and  warn "# LMach key:  Class=$class <=$xclass, ",
  "$nkeys subkeys <=$xkey, $nvals vals <=($xval,$xdata), sec<=$xsec.\n";
print $ok ? "" : "not ", "ok 2\n";

$ok= RegEnumKeyEx( HKEY_LOCAL_MACHINE, 0, $key, $klen=$zero,
		   [], $class, $clen=0, [] );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
$Debug  and  warn "# First LMach subkey:  Name=$key, Class=$class.\n";
print $ok ? "" : "not ", "ok 3\n";

$ok= (  $klen == length($key)  &&  $clen == length($class)  );
print $ok ? "" : "not ", "ok 4\n";

$ok= RegEnumKeyEx( HKEY_LOCAL_MACHINE, $nkeys-1, $key, $klen=0,
		   [], $class, $clen=0, $time );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
$Debug  and  warn "# Last LMach subkey:  Name=$key, Class=$class.\n";
print $ok ? "" : "not ", "ok 5\n";

$ok= RegEnumKeyExW( HKEY_LOCAL_MACHINE, $nkeys-1, $wkey, $wklen=0,
		    [], $wclass, $wclen=0, $wtime );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
if(  $Debug  ) {
    $_= "Last LMach subkey:  Wide name=$wkey, Wide class=$wclass.";
    s#([^ -~])#sprintf "\\x%02X",unpack("C",$1)#ge;
    warn "# $_\n";
}
print $ok ? "" : "not ", "ok 6\n";

$ok= (  $wklen == $klen  &&  2*$wklen == length($wkey)
    &&  $wclen == $clen  &&  2*$wclen == length($wclass)
    &&  $time eq $wtime  );
print $ok ? "" : "not ", "ok 7\n";

$ok= RegOpenKeyEx( HKEY_LOCAL_MACHINE, $key, 0, KEY_READ, $hkey );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
$Debug  and  warn "# LMach\\$key handle is $hkey.\n";
print $ok ? "" : "not ", "ok 8\n";

$ok= RegQueryInfoKey( $hkey, $kclass, $clen=0, [],
  $nkeys, [], [], $nvals, $xval, $xdata, $xsec, $time );
$Debug  and  warn "# LMach\\$key:  Class=$kclass <=?, ",
  "$nkeys subkeys <=?, $nvals vals <=($xval,$xdata), sec<=$xsec.\n";
print $ok ? "" : "not ", "ok 9\n";

$ok= (  $class eq $kclass  );
print $ok ? "" : "not ", "ok 10\n";

$path= $key;
while(  0 == $nvals  ) {

    $ok= RegEnumKeyEx( $hkey, $nkeys-1, $key2, $klen2=2*$zero,
		       [], $class2, $clen2=1*$zero, $time );
    $ok  or  die "Can't find key with values:  ",regLastError(),"\n";
    $Debug  and  warn
      "# Last LMach\\$path subkey:  Name=$key2, Class=$class2.\n";
    $path .= "\\$key2";
    $clen2= $klen2;	# Don't warn about these vars being used but once.

    $ok= RegOpenKeyEx( $hkey, $key2, 0, KEY_READ, $hkey2 );
    $Debug && !$ok  and  warn "# ",regLastError(),"\n";
    $Debug  and  warn "# LMach\\$path handle is $hkey2.\n";

    $ok= RegCloseKey( $hkey );
    $Debug && !$ok  and  warn "# RegCloseKey: ",regLastError(),"\n";

    $hkey= $hkey2;

    $ok= RegQueryInfoKey( $hkey, $kclass, [],
      $nkeys, $xkey, $xclass, $nvals, $xval, $xdata, [], $time );
    $Debug && !$ok  and  warn "# ",regLastError(),"\n";
    $Debug  and  warn "# LMach\\$path:  Class=$kclass <=$xclass, ",
      "$nkeys subkeys <=$xkey, $nvals vals <=($xval,$xdata).\n";

}

$ok= RegOpenKeyEx( HKEY_LOCAL_MACHINE, $path, 0, KEY_READ, $hkey2 );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
$Debug  and  warn "# LMach\\$path new handle is $hkey2.\n";
print $ok ? "" : "not ", "ok 11\n";

$ok= RegEnumValue( $hkey, 0, $name, $nlen=0, [], $type, $data, $dlen=0 );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
if(  $Debug  ) {
    $_= "First LMach\\$path val:  Name=$name, Type=$type, Data=$data.";
    s#([^ -~])#sprintf "\\x%02X",unpack("C",$1)#ge;
    warn "# $_\n";
}
print $ok ? "" : "not ", "ok 12\n";
@valnames= ($name);

$ok= RegEnumValueA( $hkey, $nvals-1, $name, $nlen=$zero,
		    [], $type, $data, $dlen=0 );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
if(  $Debug  ) {
    $_= "Last LMach\\$path val:  Name=$name, Type=$type, Data=$data.";
    s#([^ -~])#sprintf "\\x%02X",unpack("C",$1)#ge;
    warn "# $_\n";
}
print $ok ? "" : "not ", "ok 13\n";
push( @valnames, $name );

$ok= (  $nlen == length($name)  &&  $dlen == length($data)  );
print $ok ? "" : "not ", "ok 14\n";

$ok= RegQueryValueEx( $hkey, $name, [], $vtype, $vdata, $vdlen=0 );
if(  $Debug  ) {
    $_= "LMach\\$key\\$key2\\$name:  Type=$vtype, Data=$vdata.";
    s#([^ -~])#sprintf "\\x%02X",unpack("C",$1)#ge;
    warn "# $_\n";
}
print $ok ? "" : "not ", "ok 15\n";

$ok= (  $type == $vtype  &&  $data eq $vdata  &&  $dlen == $vdlen  );
$Debug  and  warn "# length(data)=",length($data)," length(vdata)=",
  length($vdata), " dlen=$dlen, vdlen=$vdlen.\n";
print $ok ? "" : "not ", "ok 16\n";

$pValueEnts= pack( " p x4 x4 x4 " x @valnames, @valnames );
$ok= RegQueryMultipleValues( $hkey, $pValueEnts, 0+@valnames, $buffer, 1 );
print $ok ? "" : "not ", "ok 17\n";

@lens=  unpack( " x4 L x4 x4 " x @valnames, $pValueEnts );
@types= unpack( " x4 x4 x4 L " x @valnames, $pValueEnts );
@dat1=  unpack(  join( "", map(" x4 x4 P$_ x4 ",@lens) ), $pValueEnts  );
@dat2=  unpack( join("",map("a$_",@lens)), $buffer );
if(  $ok= ( @dat1==@dat2 && @dat1==@types )  ) {
    for(0..$#dat1) { if( $dat1[$_] ne $dat2[$_] ) { $ok= 0; last; } }
}
print $ok ? "" : "not ", "ok 18\n";


$ok= RegCloseKey( $hkey );
$Debug && !$ok  and  warn "# ",regLastError(),"\n";
print $ok ? "" : "not ", "ok 19\n";

$ok= ! RegEnumValue( $hkey, 0, $name, $nlen=0, [], $type, $data, $dlen=0 );
print $ok ? "" : "not ", "ok 20\n";
$Debug  and  warn "# Using closed key gives:  `",regLastError(),"'.\n";

$ok= (  regLastError() =~ /handle/i  &&  regLastError() =~ /invali/i  );
print $ok ? "" : "# ".regLastError()."\nnot ", "ok 21\n";

$ok= (  $type == $vtype  &&  $data eq $vdata  );
print $ok ? "" : "not ", "ok 22\n";

$ok=	HKEY_CLASSES_ROOT &&	HKEY_CURRENT_CONFIG &&	HKEY_CURRENT_USER
 &&	HKEY_DYN_DATA &&	HKEY_LOCAL_MACHINE &&	HKEY_PERFORMANCE_DATA
 &&	HKEY_USERS;
print $ok ? "" : "not ", "ok 23\n";

$ok=	KEY_QUERY_VALUE &&	KEY_SET_VALUE &&	KEY_CREATE_SUB_KEY
 &&	KEY_ENUMERATE_SUB_KEYS &&	KEY_NOTIFY &&	KEY_CREATE_LINK
 &&	KEY_READ &&		KEY_WRITE &&		KEY_EXECUTE
 &&	KEY_ALL_ACCESS;
print $ok ? "" : "not ", "ok 24\n";

$ok=	0==REG_OPTION_RESERVED && 0==REG_OPTION_NON_VOLATILE
 &&	REG_OPTION_VOLATILE
 &&	REG_OPTION_CREATE_LINK && REG_OPTION_BACKUP_RESTORE
 &&	REG_OPTION_OPEN_LINK &&	REG_LEGAL_OPTION &&	REG_CREATED_NEW_KEY
 &&	REG_OPENED_EXISTING_KEY && REG_WHOLE_HIVE_VOLATILE && REG_REFRESH_HIVE
 &&	REG_NO_LAZY_FLUSH &&	REG_NOTIFY_CHANGE_ATTRIBUTES
 &&	REG_NOTIFY_CHANGE_NAME && REG_NOTIFY_CHANGE_LAST_SET
 &&	REG_NOTIFY_CHANGE_SECURITY &&			REG_LEGAL_CHANGE_FILTER
 &&	0==REG_NONE &&		REG_SZ &&		REG_EXPAND_SZ
 &&	REG_BINARY &&		REG_DWORD &&		REG_DWORD_LITTLE_ENDIAN
 &&	REG_DWORD_BIG_ENDIAN &&	REG_LINK &&		REG_MULTI_SZ
 &&	REG_RESOURCE_LIST &&	REG_FULL_RESOURCE_DESCRIPTOR
 &&	REG_RESOURCE_REQUIREMENTS_LIST;
print $ok ? "" : "not ", "ok 25\n";

$ok=  ! eval { AbortSystemShutdown( [] ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 26\n";

$ok= 1;
#$ok=  ! eval { InitiateSystemShutdown([],[],0,0,0) }  &&  $@ eq "";
#$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 27\n";

$ok=  ! eval { RegCloseKey(0) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 28\n";

$ok=  ! eval { RegConnectRegistry(":",0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 29\n";

$ok=  ! eval { RegCreateKey(0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 30\n";

$ok=  ! eval { RegCreateKeyEx(0,[],0,[],0,0,[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 31\n";

$ok=  ! eval { RegDeleteKey(0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 32\n";

$ok=  ! eval { RegDeleteValue(0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 33\n";

$ok=  ! eval { RegEnumKey(0,0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 34\n";

$ok=  ! eval { RegEnumKey(0,0,[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 35\n";

$ok=  ! eval { RegEnumKeyEx(0,0,[],[],[],[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 36\n";

$ok=  ! eval { RegEnumKeyEx(0,0,[]   ,[],[],   []) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 37\n";

$ok=  ! eval { RegEnumValue(0,0,[],[],[],[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 38\n";

$ok=  ! eval { RegEnumValue(0,0,[]   ,[],[],[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 39\n";

$ok=  ! eval { RegFlushKey(0) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 40\n";

$ok=  ! eval { RegGetKeySecurity(0,0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 41\n";

$ok=  ! eval { RegGetKeySecurity(0,0,[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 42\n";

$ok=  ! eval { RegLoadKey(0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 43\n";

$ok=  ! eval { RegNotifyChangeKeyValue(0,0,0,[],0) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 44\n";

$ok=  ! eval { RegOpenKey(0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 45\n";

$ok=  ! eval { RegOpenKeyEx(0,[],0,0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 46\n";

$ok=  ! eval { RegQueryInfoKey(0,[],[],([])x9) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 47\n";

$ok=  ! eval { RegQueryInfoKey(0,[]   ,([])x9) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 48\n";

$ok=  ! eval { RegQueryMultipleValues(0,[],0,[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 49\n";

$ok=  ! eval { RegQueryMultipleValues(0,[],0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 50\n";

$ok=  ! eval { RegQueryValue(0,[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 51\n";

$ok=  ! eval { RegQueryValue(0,[],[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 52\n";

$ok=  ! eval { RegQueryValueEx(0,[],[],[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 53\n";

$ok=  ! eval { RegQueryValueEx(0,[],[],[],[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 54\n";

$ok=  ! eval { RegReplaceKey(0,[],[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 55\n";

$ok=  ! eval { RegRestoreKey(0,[],0) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 56\n";

$ok=  ! eval { RegSaveKey(0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 57\n";

$ok=  ! eval { RegSetKeySecurity(0,0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 58\n";

$ok=  ! eval { RegSetValue(0,[],0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 59\n";

$ok=  ! eval { RegSetValue(0,[],0,[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 60\n";

$ok=  ! eval { RegSetValueEx(0,[],0,0,[],[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 61\n";

$ok=  ! eval { RegSetValueEx(0,[],0,0,[]   ) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 62\n";

$ok=  ! eval { RegUnLoadKey(0,[]) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 63\n";

$ok=  ! eval { AllowPriv("",1) }  &&  $@ eq "";
$Debug && $@ && warn "# \$@=$@\n";
print $ok ? "" : "not ", "ok 64\n";

$test= 64;
my %consts;
my @consts= @Win32API::Registry::EXPORT_OK;
@consts{@consts}= @consts;

my( @noargs, %noargs )= qw( regLastError );
@noargs{@noargs}= @noargs;

foreach $func ( @{$Win32API::Registry::EXPORT_TAGS{Func}} ) {
    delete $consts{$func};
    if(  defined( $noargs{$func} )  ) {
	$ok=  ! eval("$func(0,0)")  &&  $@ =~ /(::|\s)_?${func}A?[(:\s]/;
    } else {
	$ok=  ! eval("$func()")  &&  $@ =~ /(::|\s)_?${func}A?[(:\s]/;
    }
    $Debug && !$ok && warn "# $func: $@\n";
    print $ok ? "" : "not ", "ok ", ++$test, "\n";
}

foreach $func ( @{$Win32API::Registry::EXPORT_TAGS{FuncA}},
                @{$Win32API::Registry::EXPORT_TAGS{FuncW}} ) {
    $ok=  ! eval("$func()")  &&  $@ =~ /::_?${func}\(/;
    delete $consts{$func};
    $Debug && !$ok && warn "# $func: $@\n";
    print $ok ? "" : "not ", "ok ", ++$test, "\n";
}

foreach $const ( keys(%consts) ) {
    $ok= eval("my \$x= $const(); 1");
    $Debug && !$ok && warn "# Constant $const: $@\n";
    print $ok ? "" : "not ", "ok ", ++$test, "\n";
}

__END__
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)