=head1 NAME

CFX5::Win32::Registry - routines for registry access on Windows

=head1 SYNOPSIS

  use CFX5::Win32::Registry;
  warn registry_get('Software/Foo/Blah');

=head1 DESCRIPTION

A Perl module for reading (and possibly, eventually, writing) the
Windows registry.  The idea is to provide a very simple and limited
API which fits the way CFX-5.4 wants to use it, rather than a fully
sophisticated set of routines.

This module is implemented around the C<Win32API::Registry> module.

It is safe to C<use> this module on UNIX systems, but all calls will
return failure.

=cut

package CFX5::Win32::Registry;

use strict;

use base 'Exporter';
use vars qw(@EXPORT_OK %EXPORT_TAGS);
@EXPORT_OK = (qw(registry_get registry_get_all registry_list_subkeys));
%EXPORT_TAGS = (
		ALL => \@EXPORT_OK,
	       );
use CFX5::Output ':all';
use CFX5::PathManip qw(normalize_filename basename dirname);

=head2 CONSTANTS

Because of the way we use the compiler on NT, constant functions make
things unhappy.  I can no longer even remember why.  But here we make
the following constants exportable as variables, which do still work:

HKEY_CURRENT_USER HKEY_LOCAL_MACHINE KEY_READ 
REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ

They are exportable via the export tag C<CONST>.

=cut

# use the Win32::Registry function on NT ...
use vars qw($IsNT);
BEGIN {
  if ($^O eq 'MSWin32') {
    require Win32API::Registry;
    import Win32API::Registry qw(:ALL);
    $IsNT = 1;
  } else {
    $IsNT = 0;
  }

  # we need to expand these at compile time, as the compiler doesn't
  # like them.  We do them outside the if() above to pacify strict.
  my @vars=qw(HKEY_CURRENT_USER HKEY_LOCAL_MACHINE KEY_READ 
	      REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
	      ERROR_NO_MORE_ITEMS);
  for my $v (@vars) {
    import vars ("\$$v");
    eval "\$$v = \&$v();";
  }

  # make these variables exportable too
  push @EXPORT_OK, map { "\$".$_ } @vars;
  $EXPORT_TAGS{CONST} = [ map { "\$".$_ } @vars ];
}

=head2 READING

=head3 registry_get

I<Exportable>

  $var=registry_get('Software/CFX/CFX/CFX/Something');

Reads the given path from the registry, and returns the value read.
The path is looked for first under C<HKEY_CURRENT_USER> and then under
C<HKEY_LOCAL_MACHINE>.

This call cannot currently read the default key.

Forward slashes are converted to backslashes before being passed to
any Win32 API calls.

On UNIX systems, returns undef.

=cut

sub registry_get {
  my $path=shift;

  return undef unless $IsNT;

  #
  # we're on Windows NT, so check the registry
  #

  $path=normalize_filename($path);
  # absolute paths don't work
  $path =~ s!^[\\/]*!!;
  my $keyname=dirname($path);
  my $valname=basename($path);

  for my $rootp ([$HKEY_CURRENT_USER,'HKCU'],
		 [$HKEY_LOCAL_MACHINE,'HKLM']) {
    my ($root,$rootname)=@$rootp;
    _debug("looking for $rootname\\$keyname");
    my $key=0;
    RegOpenKeyEx($root, $keyname, 0, $KEY_READ, $key)
      or next;
    
    # OK, we've found something ... get it!
    _debug("Found something promising");

    #
    # first, look for the License attribute, as set by newer
    # versions of the CFX licensing tools, and if that fails ... ?
    #
    my $rv;
    my ($type, $data,$len)=(0,chr(0) x 512,0);
    if (RegQueryValueEx($key, $valname, [], $type, $data, $len)
	# in some cases (I think it's a corrupted registry, the
	# regedit tool can't cope with it either) the call can
	# succeed, but not actually fill in the $data correctly.  In
	# this case, $len will be 0, but if we unpack $data we get a
	# segfault.
	and $len) {
      if ($type == $REG_SZ || $type == $REG_EXPAND_SZ) {
	# string value; assume it's reasonable.  It will, however, be
	# NULL-terminated.
	($rv=$data) =~ s!\0.*$!!;
      } elsif ($type == $REG_DWORD) {
	$rv=unpack("L",$data);
      } elsif ($type == $REG_BINARY) {
	$rv=$data;
      } elsif ($type == $REG_MULTI_SZ) {
	# skip this for now
	$rv = '(unread)';
      } else {
	_debug("Unknown data type $type for $valname (data is $data)");
      }
    } else {
      _debug("Unreadable or missing value $valname");
    }
      
    RegCloseKey($key);

    if (defined $rv) {
      _debug("Read $rv");
      return $rv;
    }
  }

  #
  # nope, no luck
  #
  return undef;
}

=head3 registry_get_all

I<Exportable>

  $var=registry_get_all('Software/CFX/CFX/CFX');

Reads the given path from the registry, and returns all values under
that key as a hash.  The path is looked for under both
C<HKEY_CURRENT_USER> and C<HKEY_LOCAL_MACHINE>, and the returned data
is the combination of subkeys found under both.

Forward slashes are converted to backslashes before being passed to
any Win32 API calls.

On UNIX systems, returns the empty list.

=cut

sub registry_get_all {
  my $path=shift;

  return () unless $IsNT;

  my %hash;

  #
  # we're on Windows NT, so check the registry
  #

  $path=normalize_filename($path);
  # absolute paths don't work
  $path =~ s!^[\\/]*!!;

  for my $rootp ([$HKEY_CURRENT_USER,'HKCU'],
		 [$HKEY_LOCAL_MACHINE,'HKLM']) {
    my ($root,$rootname)=@$rootp;
    _debug("looking for $rootname\\$path");
    my $key=0;
    RegOpenKeyEx($root, $path, 0, $KEY_READ, $key)
      or next;
    
    # OK, we've found something ... get it!
    _debug("Found something promising");

    my $index=0;
    my $name=" " x 128;
    my $rv;
    # 234 => ERROR_MORE_DATA; we should really handle this properly,
    # but I'm too lazy. (It means the $name variable is too
    # small). 128 should be enough; otherwise, we'll fail to find this
    # entry when we try, but at least carry on!
    while (RegEnumValue($key, $index++, $name, length($name), [], [], [], [])
	   || $^E == 234) {
      # RegEnumValue apparrently has bugs in buffer allocation, so we
      # use RegQueryValueEx instead.
      $hash{$name} = registry_get("$path\\$name");
    }

    RegCloseKey($key);
    last;
  }

  return %hash;
}

=head3 registry_list_subkeys

I<Exportable>

  $var=registry_list_subkeys('Software/CFX/CFX/CFX');

Reads the given path from the registry, and returns all subkeys of
that key as a hash.  The path is looked for first under
C<HKEY_CURRENT_USER> and then under C<HKEY_LOCAL_MACHINE>.

This call cannot currently read the default key.

Forward slashes are converted to backslashes before being passed to
any Win32 API calls.

On UNIX systems, returns the empty list.

=cut

sub registry_list_subkeys {
  my $path=shift;

  return () unless $IsNT;

  my @rv;

  #
  # we're on Windows NT, so check the registry
  #

  $path=normalize_filename($path);
  # absolute paths don't work
  $path =~ s!^[\\/]*!!;

  for my $rootp ([$HKEY_CURRENT_USER,'HKCU'],
		 [$HKEY_LOCAL_MACHINE,'HKLM']) {
    my ($root,$rootname)=@$rootp;
    _debug("looking for $rootname\\$path");
    my $key=0;
    RegOpenKeyEx($root, $path, 0, $KEY_READ, $key)
      or next;
    
    # OK, we've found something ... get it!
    _debug("Found something promising");

    my $index=0;
    my $name=" " x 128;
    my $rv;
    # 234 => ERROR_MORE_DATA; we should really handle this properly,
    # but I'm too lazy. (It means the $name variable is too
    # small). 128 should be enough; otherwise, we'll fail to find this
    # entry when we try, but at least carry on!
    while (RegEnumKeyEx($key, $index++, $name, length($name), [], [], [], [])
	   || $^E == 234) {
      push @rv, $name;
    }

    RegCloseKey($key);
  }

  return @rv;
}

1;
