?? tieregistry.pm
字號:
# 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= "";
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -