tieregistry.pm

ARM上的如果你对底层感兴趣

sub DELETE
{
  my $self= shift(@_);
  my $ent= shift(@_);
  my $delim= $self->Delimiter;
  my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
  my $sub;
  my $fast= defined(wantarray) ? $self->FastDelete : 2;
  my $old= 1;	# Value returned if FastDelete is set.
    if(  defined($key)
     &&  ( defined($val) || defined($ambig) || defined($subkey) )  ) {
	return wantarray ? () : undef
	  unless  $sub= $self->new( $key );
    } else {
	$sub= $self;
    }
    if(  defined($val)  ) {
	$old= $sub->GetValue($val) || _Err   unless  2 <= $fast;
	$sub->RegDeleteValue( $val );
    } elsif(  defined($subkey)  ) {
	$old= $sub->_FetchOld( $subkey.$delim )   unless  $fast;
	$sub->RegDeleteKey( $subkey );
    } elsif(  defined($ambig)  ) {
	if(  defined($key)  ) {
	    $old= $sub->DELETE($ambig);
	} else {
	    $old= $sub->GetValue($ambig) || _Err   unless  2 <= $fast;
	    if(  defined( $old )  ) {
		$sub->RegDeleteValue( $ambig );
	    } else {
		$old= $sub->_FetchOld( $ambig.$delim )   unless  $fast;
		$sub->RegDeleteKey( $ambig );
	    }
	}
    } elsif(  defined($key)  ) {
	$old= $sub->_FetchOld( $key.$delim )   unless  $fast;
	$sub->RegDeleteKey( $key );
    } else {
	croak "${PACK}->DELETE:  Key ($ent) can never be deleted";
    }
    $old;
}


sub SetValue
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $name= shift(@_);
  my $data= shift(@_);
  my( $type )= @_;
  my $size;
    if(  ! defined($type)  ) {
	if(  "ARRAY" eq ref($data)  ) {
	    croak "${PACK}->SetValue:  Value is array reference but ",
		  "no data type given"
	      unless  2 == @$data;
	    ( $data, $type )= @$data;
	} else {
	    $type= REG_SZ;
	}
    }
    $type= Win32API::Registry::constant($type,0)   if  $type =~ /^REG_/;
    if(  REG_MULTI_SZ == $type  &&  "ARRAY" eq ref($data)  ) {
	$data= join( "\0", @$data ) . "\0\0";
	## $data= pack(  "a*" x (1+@$data),  map( $_."\0", @$data, "" )  );
    } elsif(  ( REG_SZ == $type || REG_EXPAND_SZ == $type )
          &&  $self->FixSzNulls  ) {
	$data .= "\0"    unless  "\0" eq substr($data,0,-1);
    } elsif(  REG_DWORD == $type  &&  $data =~ /^0x[0-9a-fA-F]{3,}$/  ) {
	$data= pack( "L", hex($data) );
	# We could to $data=pack("L",$data) for REG_DWORD but I see
	# no nice way to always destinguish when to do this or not.
    }
    $self->RegSetValueEx( $name, 0, $type, $data, length($data) );
}


sub StoreKey
{
  my $this= shift(@_);
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my $subKey= shift(@_);
  my $data= shift(@_);
  my $ent;
  my $self;
    if(  ! ref($data)  ||  "$data" !~ /(^|=)HASH/  ) {
	croak "${PACK}->StoreKey:  For ", $this->Path.$subKey, ",\n",
	      "  subkey data must be a HASH reference";
    }
    if(  defined( $$data{""} )  &&  "HASH" eq ref($$data{""})  ) {
	$self= $this->CreateKey( $subKey, delete $$data{""} );
    } else {
	$self= $this->CreateKey( $subKey );
    }
    return wantarray ? () : undef   if  ! defined($self);
    foreach $ent (  keys(%$data)  ) {
	return wantarray ? () : undef
	  unless  $self->STORE( $ent, $$data{$ent} );
    }
    $self;
}


# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key
# = "string" creates a new REG_SZ value
# = [ data, type ] creates a new value
sub STORE
{
  my $self= shift(@_);
  my $ent= shift(@_);
  my $data= shift(@_);
  my $delim= $self->Delimiter;
  my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
  my $sub;
    if(  defined($key)
     &&  ( defined($val) || defined($ambig) || defined($subkey) )  ) {
	return wantarray ? () : undef
	  unless  $sub= $self->new( $key );
    } else {
	$sub= $self;
    }
    if(  defined($val)  ) {
	croak "${PACK}->STORE:  For ", $sub->Path.$delim.$val, ",\n",
	      "  value data cannot be a HASH reference"
	  if  ref($data)  &&  "$data" =~ /(^|=)HASH/;
	$sub->SetValue( $val, $data );
    } elsif(  defined($subkey)  ) {
	croak "${PACK}->STORE:  For ", $sub->Path.$subkey.$delim, ",\n",
	      "  subkey data must be a HASH reference"
	  unless  ref($data)  &&  "$data" =~ /(^|=)HASH/;
	$sub->StoreKey( $subkey, $data );
    } elsif(  defined($ambig)  ) {
	if(  ref($data)  &&  "$data" =~ /(^|=)HASH/  ) {
	    $sub->StoreKey( $ambig, $data );
	} else {
	    $sub->SetValue( $ambig, $data );
	}
    } elsif(  defined($key)  ) {
	croak "${PACK}->STORE:  For ", $sub->Path.$key.$delim, ",\n",
	      "  subkey data must be a HASH reference"
	  unless  ref($data)  &&  "$data" =~ /(^|=)HASH/;
	$sub->StoreKey( $key, $data );
    } else {
	croak "${PACK}->STORE:  Key ($ent) can never be created nor set";
    }
}


sub EXISTS
{
  my $self= shift(@_);
  my $ent= shift(@_);
    defined( $self->FETCH($ent) );
}


sub FIRSTKEY
{
  my $self= shift(@_);
  my $members= $self->_MemberNames;
    $self->{PREVIDX}= 0;
    @{$members} ? $members->[0] : undef;
}


sub NEXTKEY
{
  my $self= shift(@_);
  my $prev= shift(@_);
  my $idx= $self->{PREVIDX};
  my $members= $self->_MemberNames;
    if(  ! defined($idx)  ||  $prev ne $members->[$idx]  ) {
	$idx= 0;
	while(  $idx < @$members  &&  $prev ne $members->[$idx]  ) {
	    $idx++;
	}
    }
    $self->{PREVIDX}= ++$idx;
    $members->[$idx];
}


sub DESTROY
{
  my $self= shift(@_);
    return   if  tied(%$self);
  my $unload= $self->{UNLOADME};
  my $debug= $ENV{DEBUG_TIE_REGISTRY};
    if(  defined($debug)  ) {
	if(  1 < $debug  ) {
	  my $hand= $self->Handle;
	  my $dep= $self->{DEPENDON};
	    carp "${PACK} destroying ", $self->Path, " (",
		 "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")",
		 defined($dep) ? (" [depends on ",$dep->Path,"]") : ();
	} else {
	    warn "${PACK} destroying ", $self->Path, ".\n";
	}
    }
    $self->RegCloseKey
      unless  "NONE" eq $self->Handle;
    if(  defined($unload)  ) {
	if(  defined($debug)  &&  1 < $debug  ) {
	  my( $obj, $subKey, $file )= @$unload;
	    warn "Unloading ", $self->Path,
	      " (from ", $obj->Path, ", $subKey)...\n";
	}
	$self->UnLoad
	  ||  warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n";
	## carp "Never unloaded ${PACK}::Load($$unload[2])";
    }
    #delete $self->{DEPENDON};
}


use vars qw( @CreateKey_Opts %CreateKey_Opts );
@CreateKey_Opts= qw( Access Class Options Delimiter
		     Disposition Security Volatile Backup );
@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts;

sub CreateKey
{
  my $self= shift(@_);
  my $tied= tied(%$self);
    $self= tied(%$self)  if  $tied;
  my( $subKey, $opts )= @_;
  my( $sam )= $self->Access;
  my( $delim )= $self->Delimiter;
  my( $class )= "";
  my( $flags )= 0;
  my( $secure )= [];
  my( $garb )= 0;
  my( $result )= \$garb;
  my( $handle )= 0;
    if(  @_ < 1  ||  2 < @_
     ||  2 == @_ && "HASH" ne ref($opts)  ) {
	croak "Usage:  \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n",
	      "  options: @CreateKey_Opts\nCalled";
    }
    if(  defined($opts)  ) {
	$sam= $opts->{"Access"}   if  defined($opts->{"Access"});
	$class= $opts->{Class}   if  defined($opts->{Class});
	$flags= $opts->{Options}   if  defined($opts->{Options});
	$delim= $opts->{"Delimiter"}   if  defined($opts->{"Delimiter"});
	$secure= $opts->{Security}   if  defined($opts->{Security});
	if(  defined($opts->{Disposition})  ) {
	    "SCALAR" eq ref($opts->{Disposition})
	      or  croak "${PACK}->CreateKey option `Disposition'",
			" must provide a scalar reference";
	    $result= $opts->{Disposition};
	}
	$result= ${$opts->{Disposition}}   if  defined($opts->{Disposition});
	if(  0 == $flags  ) {
	    $flags |= REG_OPTION_VOLATILE
	      if  defined($opts->{Volatile})  &&  $opts->{Volatile};
	    $flags |= REG_OPTION_BACKUP_RESTORE
	      if  defined($opts->{Backup})  &&  $opts->{Backup};
	}
    }
  my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim);
    $subKey= join( $self->OS_Delimiter, @$subPath );
    $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam,
			   $secure, $handle, $$result )
      or  return wantarray ? () : undef;
  my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] );
    $new->{ACCESS}= $sam;
    $new->{DELIM}= $delim;
    $new= $new->TiedRef   if  $tied;
    return $new;
}


use vars qw( $Load_Cnt @Load_Opts %Load_Opts );
$Load_Cnt= 0;
@Load_Opts= qw(NewSubKey);
@Load_Opts{@Load_Opts}= (1) x @Load_Opts;

sub Load
{
  my $this= shift(@_);
  my $tied=  ref($this)  &&  tied(%$this);
    $this= tied(%$this)  if  $tied;
  my( $file, $subKey, $opts )= @_;
    if(  2 == @_  &&  "HASH" eq ref($subKey)  ) {
	$opts= $subKey;
	undef $subKey;
    }
    @_ < 1  ||  3 < @_  ||  defined($opts) && "HASH" ne ref($opts)
      and  croak "Usage:  \$key= ",
	     "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n",
	     "  options: @Load_Opts @new_Opts\nCalled";
    if(  defined($opts)  &&  exists($opts->{NewSubKey})  ) {
	$subKey= delete $opts->{NewSubKey};
    }
    if(  ! defined( $subKey )  ) {
	if(  "" ne $this->Machine  ) {
	    ( $this )= $this->_connect( [$this->Machine,"LMachine"] );
	} else {
	    ( $this )= $this->_rootKey( "LMachine" );	# Could also be "Users"
	}
	$subKey= "PerlTie:$$." . ++$Load_Cnt;
    }
    $this->RegLoadKey( $subKey, $file )
      or  return wantarray ? () : undef;
  my $self= $this->new( $subKey, defined($opts) ? $opts : () );
    if(  ! defined( $self )  ) {
	{ my $err= Win32::GetLastError();
	#{ local( $^E );
	    $this->RegUnLoadKey( $subKey )
	      or  carp "Can't unload $subKey from ", $this->Path, ": $^E\n";
	    Win32::SetLastError($err);
	}
	return wantarray ? () : undef;
    }
    $self->{UNLOADME}= [ $this, $subKey, $file ];
    $self= $self->TiedRef   if  $tied;
    $self;
}


sub UnLoad
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    @_  and  croak "Usage:  \$key->UnLoad;";
  my $unload= $self->{UNLOADME};
    "ARRAY" eq ref($unload)
      or  croak "${PACK}->UnLoad called on a key which was not Load()ed";
  my( $obj, $subKey, $file )= @$unload;
    $self->RegCloseKey;
    Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey );
}


sub AllowSave
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    $self->AllowPriv( "SeBackupPrivilege", @_ );
}


sub AllowLoad
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    $self->AllowPriv( "SeRestorePrivilege", @_ );
}


# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync )


sub RegCloseKey { my $self= shift(@_);
    Win32API::Registry::RegCloseKey $self->Handle, @_; }
sub RegConnectRegistry { my $self= shift(@_);
    Win32API::Registry::RegConnectRegistry @_; }
sub RegCreateKey { my $self= shift(@_);
    Win32API::Registry::RegCreateKey $self->Handle, @_; }
sub RegCreateKeyEx { my $self= shift(@_);
    Win32API::Registry::RegCreateKeyEx $self->Handle, @_; }
sub RegDeleteKey { my $self= shift(@_);
    Win32API::Registry::RegDeleteKey $self->Handle, @_; }
sub RegDeleteValue { my $self= shift(@_);
    Win32API::Registry::RegDeleteValue $self->Handle, @_; }
sub RegEnumKey { my $self= shift(@_);
    Win32API::Registry::RegEnumKey $self->Handle, @_; }
sub RegEnumKeyEx { my $self= shift(@_);
    Win32API::Registry::RegEnumKeyEx $self->Handle, @_; }
sub RegEnumValue { my $self= shift(@_);
    Win32API::Registry::RegEnumValue $self->Handle, @_; }
sub RegFlushKey { my $self= shift(@_);
    Win32API::Registry::RegFlushKey $self->Handle, @_; }
sub RegGetKeySecurity { my $self= shift(@_);
    Win32API::Registry::RegGetKeySecurity $self->Handle, @_; }
sub RegLoadKey { my $self= shift(@_);
    Win32API::Registry::RegLoadKey $self->Handle, @_; }
sub RegNotifyChangeKeyValue { my $self= shift(@_);
    Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; }
sub RegOpenKey { my $self= shift(@_);
    Win32API::Registry::RegOpenKey $self->Handle, @_; }
sub RegOpenKeyEx { my $self= shift(@_);
    Win32API::Registry::RegOpenKeyEx $self->Handle, @_; }
sub RegQueryInfoKey { my $self= shift(@_);
    Win32API::Registry::RegQueryInfoKey $self->Handle, @_; }
sub RegQueryMultipleValues { my $self= shift(@_);
    Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; }
sub RegQueryValue { my $self= shift(@_);
    Win32API::Registry::RegQueryValue $self->Handle, @_; }
sub RegQueryValueEx { my $self= shift(@_);
    Win32API::Registry::RegQueryValueEx $self->Handle, @_; }
sub RegReplaceKey { my $self= shift(@_);
    Win32API::Registry::RegReplaceKey $self->Handle, @_; }
sub RegRestoreKey { my $self= shift(@_);
    Win32API::Registry::RegRestoreKey $self->Handle, @_; }
sub RegSaveKey { my $self= shift(@_);
    Win32API::Registry::RegSaveKey $self->Handle, @_; }
sub RegSetKeySecurity { my $self= shift(@_);
    Win32API::Registry::RegSetKeySecurity $self->Handle, @_; }
sub RegSetValue { my $self= shift(@_);
    Win32API::Registry::RegSetValue $self->Handle, @_; }
sub RegSetValueEx { my $self= shift(@_);
    Win32API::Registry::RegSetValueEx $self->Handle, @_; }
sub RegUnLoadKey { my $self= shift(@_);
    Win32API::Registry::RegUnLoadKey $self->Handle, @_; }
sub AllowPriv { my $self= shift(@_);
    Win32API::Registry::AllowPriv @_; }


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__