# Win32/TieRegistry.pm -- Perl module to easily use a Registry
# (on Win32 systems so far).
# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.

#
# Skip to "=head" line for user documentation.
#

package Win32::TieRegistry;

use strict;
use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );

$PACK= "Win32::TieRegistry";	# Used in error messages.
$VERSION= '0.21';		# Released Sept 17, 1998

use Carp;
require Tie::Hash;
@ISA= qw(Tie::Hash);

# Required other modules:
use Win32API::Registry 0.12 qw( :KEY_ :HKEY_ :REG_ );

#Optional other modules:
use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar );

if(  eval { require Win32::WinError }  ) {
    $_NoMoreItems= Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0);
    $_FileNotFound= Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0);
    $_TooSmall= Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0);
    $_MoreData= Win32::WinError::constant("ERROR_MORE_DATA",0);
} else {
    $_NoMoreItems= "^No more data";
    $_FileNotFound= "cannot find the file";
    $_TooSmall= " data area passed to ";
    $_MoreData= "^more data is avail";
}
if(  $_SetDualVar= eval { require SetDualVar }  ) {
    import SetDualVar;
}


#Implementation details:
#    When opened:
#	HANDLE		long; actual handle value
#	MACHINE		string; name of remote machine ("" if local)
#	PATH		list ref; machine-relative full path for this key:
#			["LMachine","System","Disk"]
#			["HKEY_LOCAL_MACHINE","System","Disk"]
#	DELIM		char; delimiter used to separate subkeys (def="\\")
#	OS_DELIM	char; always "\\" for Win32
#	ACCESS		long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc.
#	ROOTS		string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map
#	FLAGS		int; bits to control certain options
#    Often:
#	VALUES		ref to list of value names (data/type never cached)
#	SUBKEYS		ref to list of subkey names
#	SUBCLASSES	ref to list of subkey classes
#	SUBTIMES	ref to list of subkey write times
#	MEMBERS		ref to list of subkey_name.DELIM's, DELIM.value_name's
#	MEMBHASH	hash ref to with MEMBERS as keys and 1's as values
#    Once Key "Info" requested:
#	Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
#	MaxValNameLen MaxValDataLen SecurityLen LastWrite
#    When tied to a hash and iterating over key values:
#	PREVIDX		int; index of last MEMBERS element return
#    When tied to a hash and iterating over key values:
#	UNLOADME	list ref; information about Load()ed key
#    When a subkey of a "loaded" key:
#	DEPENDON	obj ref; object that can't be destroyed before us


#Package-local variables:

# Option flag bits:
use vars qw( $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin
	     $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls );
$Flag_ArrVal=	0x0001;
$Flag_TieVal=	0x0002;
$Flag_FastDel=	0x0004;
$Flag_HexDWord=	0x0008;
$Flag_Split=	0x0010;
$Flag_DualTyp=	0x0020;
$Flag_DualBin=	0x0040;
$Flag_FixNulls=	0x0080;


use vars qw( $RegObj %_Roots %RegHash $Registry );

# Short-hand for HKEY_* constants:
%_Roots= (
    "Classes" =>	HKEY_CLASSES_ROOT,
    "CUser" =>		HKEY_CURRENT_USER,
    "LMachine" =>	HKEY_LOCAL_MACHINE,
    "Users" =>		HKEY_USERS,
    "PerfData" =>	HKEY_PERFORMANCE_DATA,	# Too picky to be useful
    "CConfig" =>	HKEY_CURRENT_CONFIG,
    "DynData" =>	HKEY_DYN_DATA,		# Too picky to be useful
);

# Basic master Registry object:
$RegObj= {};
@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= (
    "NONE", "", [], "\\", "\\",
    KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" );
$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin   if  $_SetDualVar;
bless $RegObj;

# Fill cache for master Registry object:
@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= (
    [],  [ keys(%_Roots) ],  [],  []  );
grep( s#$#$RegObj->{DELIM}#,
  @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } );
@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen
  MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}=
    ( "", 0, 0, 0, 0, 0, 0, 0, 0 );

# Create master Registry tied hash:
$RegObj->Tie( \%RegHash );

# Create master Registry combination object and tied hash reference:
$Registry= \%RegHash;
bless $Registry;


# Preloaded methods go here.

# Map option names to name of subroutine that controls that option:
use vars qw( @_opt_subs %_opt_subs );
@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex
	FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave );
@_opt_subs{@_opt_subs}= @_opt_subs;

sub import
{
  my $pkg= shift(@_);
  my $level= $Exporter::ExportLevel;
  my $expto= caller($level);
  my @export= ();
  my @consts= qw( :KEY_ :REG_ );
  my $registry= $Registry->Clone;
  local( $_ );
    while(  @_  ) {
	$_= shift(@_);
	if(  /^\$(\w+::)*\w+$/  ) {
	    push( @export, "ObjVar" )   if  /^\$RegObj$/;
	    push( @export, $_ );
	} elsif(  /^\%(\w+::)*\w+$/  ) {
	    push( @export, $_ );
	} elsif(  /^[$%]/  ) {
	    croak "${PACK}->import:  Invalid variable name ($_)";
	} elsif(  /^:/  ||  /^(H?KEY|REG)_/  ) {
	    Win32API::Registry->export( $expto, $_ )
	      unless  /^:$/;
	    @consts= ();
	} elsif(  ! @_  ) {
	    croak "${PACK}->import:  Missing argument after option ($_)";
	} elsif(  exists $_opt_subs{$_}  ) {
	    $_= $_opt_subs{$_};
	    $registry->$_( shift(@_) );
	} elsif(  /^TiedRef$/  ) {
	    $_= shift(@_);
	    if(  ! ref($_)  &&  /^(\$?)(\w+::)*\w+$/  ) {
		$_= '$'.$_   unless  '$' eq $1;
	    } elsif(  "SCALAR" ne ref($_)  ) {
		croak "${PACK}->import:  Invalid var after TiedRef ($_)";
	    }
	    push( @export, $_ );
	} elsif(  /^TiedHash$/  ) {
	    $_= shift(@_);
	    if(  ! ref($_)  &&  /^(\%?)(\w+::)*\w+$/  ) {
		$_= '%'.$_   unless  '%' eq $1;
	    } elsif(  "HASH" ne ref($_)  ) {
		croak "${PACK}->import:  Invalid var after TiedHash ($_)";
	    }
	    push( @export, $_ );
	} elsif(  /^ObjectRef$/  ) {
	    $_= shift(@_);
	    if(  ! ref($_)  &&  /^(\$?)(\w+::)*\w+$/  ) {
		push( @export, "ObjVar" );
		$_= '$'.$_   unless  '$' eq $1;
	    } elsif(  "SCALAR" eq ref($_)  ) {
		push( @export, "ObjRef" );
	    } else {
		croak "${PACK}->import:  Invalid var after ObjectRef ($_)";
	    }
	    push( @export, $_ );
	} elsif(  /^ExportLevel$/  ) {
	    $level= shift(@_);
	    $expto= caller($level);
	} elsif(  /^ExportTo$/  ) {
	    undef $level;
	    $expto= caller($level);
	} else {
	    croak "${PACK}->import:  Invalid option ($_)";
	}
    }
    @export= ('$Registry')   unless  @export;
    while(  @export  ) {
	$_= shift( @export );
	if(  /^\$((?:\w+::)*)(\w+)$/  ) {
	  my( $pack, $sym )= ( $1, $2 );
	    $pack= $expto   unless  defined($pack)  &&  "" ne $pack;
	    no strict 'refs';
	    *{"${pack}::$sym"}= \${"${pack}::$sym"};
	    ${"${pack}::$sym"}= $registry;
	} elsif(  /^\%((?:\w+::)*)(\w+)$/  ) {
	  my( $pack, $sym )= ( $1, $2 );
	    $pack= $expto   unless  defined($pack)  &&  "" ne $pack;
	    no strict 'refs';
	    *{"${pack}::$sym"}= \%{"${pack}::$sym"};
	    $registry->Tie( \%{"${pack}::$sym"} );
	} elsif(  "SCALAR" eq ref($_)  ) {
	    $$_= $registry;
	} elsif(  "HASH" eq ref($_)  ) {
	    $registry->Tie( $_ );
	} elsif(  /^ObjVar$/  ) {
	    $_= shift( @_ );
	    /^\$((?:\w+::)*)(\w+)$/;
	  my( $pack, $sym )= ( $1, $2 );
	    $pack= $expto   unless  defined($pack)  &&  "" ne $pack;
	    no strict 'refs';
	    *{"${pack}::$sym"}= \${"${pack}::$sym"};
	    ${"${pack}::$sym"}= $registry->ObjectRef;
	} elsif(  /^ObjRef$/  ) {
	    ${shift(@_)}= $registry->ObjectRef;
	} else {
	    die "Impossible var to export ($_)";
	}
    }
}

use vars qw( @_new_Opts %_new_Opts );
@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON );
@_new_Opts{@_new_Opts}= (1) x @_new_Opts;

sub _new
{
  my $this= shift( @_ );
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my $class= ref($this) || $this;
  my $self= {};
  my( $handle, $rpath, $opts )= @_;
    if(  @_ < 2  ||  "ARRAY" ne ref($rpath)  ||  3 < @_
     ||  3 == @_ && "HASH" ne ref($opts)  ) {
	croak "Usage:  ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n",
	      "  options: @_new_Opts\nCalled";
    }
    @$self{qw( HANDLE PATH )}= ( $handle, $rpath );
    @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}=
      ( $this->Machine, $this->Access, $this->Delimiter,
        $this->OS_Delimiter, $this->_Roots, $this->_Flags );
    if(  ref($opts)  ) {
      my @err= grep( ! $_new_Opts{$_}, keys(%$opts) );
	@err  and  croak "${PACK}->_new:  Invalid options (@err)";
	@$self{ keys(%$opts) }= values(%$opts);
    }
    bless $self, $class;
    return $self;
}


sub _split
{
  my $self= shift( @_ );
    $self= tied(%$self)  if  tied(%$self);
  my $path= shift( @_ );
  my $delim= @_ ? shift(@_) : $self->Delimiter;
  my $list= [ split( /\Q$delim/, $path ) ];
    $list;
}


sub _rootKey
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $keyPath= shift(@_);
  my $delim= @_ ? shift(@_) : $self->Delimiter;
  my( $root, $subPath );
    if(  "ARRAY" eq ref($keyPath)  ) {
	$subPath= $keyPath;
    } else {
	$subPath= $self->_split( $keyPath, $delim );
    }
    $root= shift( @$subPath );
    if(  $root =~ /^HKEY_/  ) {
      my $handle= Win32API::Registry::constant($root,0);
	$handle  or  croak "Invalid HKEY_ constant ($root): $!";
	return( $self->_new( $handle, [$root], {DELIM=>$delim} ),
	        $subPath );
    } elsif(  $root =~ /^([-+]|0x)?\d/  ) {
	return( $self->_new( $root, [sprintf("0x%lX",$root)],
			     {DELIM=>$delim} ),
		$subPath );
    } else {
      my $roots= $self->Roots;
	if(  $roots->{$root}  ) {
	    return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ),
	            $subPath );
	}
	croak "No such root key ($root)";
    }
}


sub _open
{
  my $this= shift(@_);
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my $subPath= shift(@_);
  my $sam= @_ ? shift(@_) : $this->Access;
  my $subKey= join( $this->OS_Delimiter, @$subPath );
  my $handle= 0;
    $this->RegOpenKeyEx( $subKey, 0, $sam, $handle )
      or  return wantarray ? () : undef;
    return $this->_new( $handle, [ @{$this->_Path}, @$subPath ],
      { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this)
	: defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () )
      } );
}


sub ObjectRef
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    $self;
}


sub _connect
{
  my $this= shift(@_);
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my $subPath= pop(@_);
    $subPath= $this->_split( $subPath )   unless  ref($subPath);
  my $machine= @_ ? shift(@_) : shift(@$subPath);
  my $handle= 0;
  my( $temp )= $this->_rootKey( [@$subPath] );
    $temp->RegConnectRegistry( $machine, $temp->Handle, $handle )
      or  return wantarray ? () : undef;
  my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} );
    ( $self, $subPath );
}


use vars qw( @Connect_Opts %Connect_Opts );
@Connect_Opts= qw(Access Delimiter);
@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts;

sub Connect
{
  my $this= shift(@_);
  my $tied=  ref($this)  &&  tied(%$this);
    $this= tied(%$this)  if  $tied;
  my( $machine, $key, $opts )= @_;
  my $delim= "";
  my $sam;
  my $subPath;
    if(  @_ < 2  ||  3 < @_
     ||  3 == @_ && "HASH" ne ref($opts)  ) {
	croak "Usage:  \$obj= ${PACK}->Connect(",
	      " \$Machine, \$subKey, { OPT=>VAL,... } );\n",
	      "  options: @Connect_Opts\nCalled";
    }
    if(  ref($opts)  ) {
      my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) );
	@err  and  croak "${PACK}->Connect:  Invalid options (@err)";
    }
    $delim= "$opts->{Delimiter}"  if  defined($opts->{Delimiter});
    $delim= $this->Delimiter   if  "" eq $delim;
    $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
    $sam= Win32API::Registry::constant($sam,0)   if  $sam =~ /^KEY_/;
    ( $this, $subPath )= $this->_connect( $machine, $key );
    return wantarray ? () : undef   unless  defined($this);
  my $self= $this->_open( $subPath, $sam );
    return wantarray ? () : undef   unless  defined($self);
    $self->Delimiter( $delim );
    $self= $self->TiedRef   if  $tied;
    return $self;
}


my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES
    Class SecurityLen LastWrite CntValues CntSubKeys
    MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen );

sub _newVirtual
{
  my $self= shift(@_);
  my( $rPath, $root, $opts )= @_;
  my $new= $self->_new( "NONE", $rPath, $opts )
      or  return wantarray ? () : undef;
    @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys};
    return $new;
}


#$key= new Win32::TieRegistry "LMachine/System/Disk";
#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk";
#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} );
#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} );
#$key->new( ... );

use vars qw( @new_Opts %new_Opts );
@new_Opts= qw(Access Delimiter);
@new_Opts{@new_Opts}= (1) x @new_Opts;

sub new
{
  my $this= shift( @_ );
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my( $subKey, $opts )= @_;
  my $delim= "";