Netrunner 2004 October/NETRUNNER0410.ISO/regular/ActivePerl-5.8.4.810-MSWin32-x86.msi/_ec3d16d5dd91eaed6e4f670b8840ca44

Text File | 2004-06-01 | 12.3 KB | 546 lines

package Win32::Registry;

=head1 NAME

Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry]

=head1 SYNOPSIS

    use Win32::Registry;
    my $tips;
    $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows"
                               ."\\CurrentVersion\\Explorer\\Tips", $tips)
        or die "Can't open tips: $^E";
    my ($type, $value);
    $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E";
    print "Here's a tip: $value\n";

=head1 DESCRIPTION

    NOTE: This module provides a very klunky interface to access the
    Windows registry, and is not currently being developed actively.  It
    only exists for backward compatibility with old code that uses it.
    For more powerful and flexible ways to access the registry, use
    Win32::TieRegistry.

Win32::Registry provides an object oriented interface to the Windows
Registry.

The following "root" registry objects are exported to the main:: name
space.  Additional keys must be opened by calling the provided methods
on one of these.

    $HKEY_CLASSES_ROOT
    $HKEY_CURRENT_USER
    $HKEY_LOCAL_MACHINE
    $HKEY_USERS
    $HKEY_PERFORMANCE_DATA
    $HKEY_CURRENT_CONFIG
    $HKEY_DYN_DATA

=cut

use strict;
require Exporter;
require DynaLoader;
use Win32::WinError;

use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION = '0.07';

@ISA    = qw( Exporter DynaLoader );
@EXPORT = qw(
    HKEY_CLASSES_ROOT
    HKEY_CURRENT_USER
    HKEY_LOCAL_MACHINE
    HKEY_PERFORMANCE_DATA
    HKEY_CURRENT_CONFIG
    HKEY_DYN_DATA
    HKEY_USERS
    KEY_ALL_ACCESS
    KEY_CREATE_LINK
    KEY_CREATE_SUB_KEY
    KEY_ENUMERATE_SUB_KEYS
    KEY_EXECUTE
    KEY_NOTIFY
    KEY_QUERY_VALUE
    KEY_READ
    KEY_SET_VALUE
    KEY_WRITE
    REG_BINARY
    REG_CREATED_NEW_KEY
    REG_DWORD
    REG_DWORD_BIG_ENDIAN
    REG_DWORD_LITTLE_ENDIAN
    REG_EXPAND_SZ
    REG_FULL_RESOURCE_DESCRIPTOR
    REG_LEGAL_CHANGE_FILTER
    REG_LEGAL_OPTION
    REG_LINK
    REG_MULTI_SZ
    REG_NONE
    REG_NOTIFY_CHANGE_ATTRIBUTES
    REG_NOTIFY_CHANGE_LAST_SET
    REG_NOTIFY_CHANGE_NAME
    REG_NOTIFY_CHANGE_SECURITY
    REG_OPENED_EXISTING_KEY
    REG_OPTION_BACKUP_RESTORE
    REG_OPTION_CREATE_LINK
    REG_OPTION_NON_VOLATILE
    REG_OPTION_RESERVED
    REG_OPTION_VOLATILE
    REG_REFRESH_HIVE
    REG_RESOURCE_LIST
    REG_RESOURCE_REQUIREMENTS_LIST
    REG_SZ
    REG_WHOLE_HIVE_VOLATILE
);

@EXPORT_OK = qw(
    RegCloseKey
    RegConnectRegistry
    RegCreateKey
    RegCreateKeyEx
    RegDeleteKey
    RegDeleteValue
    RegEnumKey
    RegEnumValue
    RegFlushKey
    RegGetKeySecurity
    RegLoadKey
    RegNotifyChangeKeyValue
    RegOpenKey
    RegOpenKeyEx
    RegQueryInfoKey
    RegQueryValue
    RegQueryValueEx
    RegReplaceKey
    RegRestoreKey
    RegSaveKey
    RegSetKeySecurity
    RegSetValue
    RegSetValueEx
    RegUnLoadKey
);
$EXPORT_TAGS{ALL}= \@EXPORT_OK;

bootstrap Win32::Registry;

sub import {
    my $pkg = shift;
    if ($_[0] && "Win32" eq $_[0]) {
    Exporter::export($pkg, "Win32", @EXPORT_OK);
    shift;
    }
    Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_);
}

#######################################################################
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.  If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.

sub AUTOLOAD {
    my($constname);
    ($constname = $AUTOLOAD) =~ s/.*:://;
    #reset $! to zero to reset any current errors.
    local $! = 0;
    my $val = constant($constname, 0);
    if ($! != 0) {
    if ($! =~ /Invalid/) {
        $AutoLoader::AUTOLOAD = $AUTOLOAD;
        goto &AutoLoader::AUTOLOAD;
    }
    else {
        my ($pack,$file,$line) = caller;
        die "Unknown constant $constname in Win32::Registry "
           . "at $file line $line.\n";
    }
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}

#######################################################################
# _new is a private constructor, not intended for public use.
#

sub _new {
    my $self;
    if ($_[0]) {
    $self->{'handle'} = $_[0];
    bless $self;
    }
    $self;
}

#define the basic registry objects to be exported.
#these had to be hardwired unfortunately.
# XXX Yuck!

{
    package main;
    use vars qw(
        $HKEY_CLASSES_ROOT
        $HKEY_CURRENT_USER
        $HKEY_LOCAL_MACHINE
        $HKEY_USERS
        $HKEY_PERFORMANCE_DATA
        $HKEY_CURRENT_CONFIG
        $HKEY_DYN_DATA
           );
}

$::HKEY_CLASSES_ROOT        = _new(&HKEY_CLASSES_ROOT);
$::HKEY_CURRENT_USER        = _new(&HKEY_CURRENT_USER);
$::HKEY_LOCAL_MACHINE        = _new(&HKEY_LOCAL_MACHINE);
$::HKEY_USERS            = _new(&HKEY_USERS);
$::HKEY_PERFORMANCE_DATA    = _new(&HKEY_PERFORMANCE_DATA);
$::HKEY_CURRENT_CONFIG        = _new(&HKEY_CURRENT_CONFIG);
$::HKEY_DYN_DATA        = _new(&HKEY_DYN_DATA);

=head2 Methods

The following methods are supported.  Note that subkeys can be
specified as a path name, separated by backslashes (which may
need to be doubled if you put them in double quotes).

=over 8

=item Open

    $reg_obj->Open($sub_key_name, $sub_reg_obj);

Opens a subkey of a registry object, returning the new registry object
in $sub_reg_obj.

=cut

sub Open {
    my $self = shift;
    die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2;

    my ($subkey) = @_;
    my ($result,$subhandle);

    $result = RegOpenKey($self->{'handle'},$subkey,$subhandle);
    $_[1] = _new($subhandle);

    return 0 unless $_[1];
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item Close

    $reg_obj->Close();

Closes an open registry key.

=cut

sub Close {
    my $self = shift;
    die 'usage: $obj->Close()' if @_ != 0;

    return unless exists $self->{'handle'};
    my $result = RegCloseKey($self->{'handle'});
    if ($result) {
    delete $self->{'handle'};
    }
    else {
    $! = Win32::GetLastError();
    }
    return $result;
}

sub DESTROY {
    my $self = shift;
    return unless exists $self->{'handle'};
    RegCloseKey($self->{'handle'});
    delete $self->{'handle'};
}


=item Connect

    $reg_obj->Connect($node_name, $new_reg_obj);

Connects to a remote Registry on the node specified by $node_name,
returning it in $new_reg_obj.  Returns false if it fails.

=cut

sub Connect {
    my $self = shift;
    die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2;

    my ($node) = @_;
    my ($result,$subhandle);

    $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle);
    $_[1] = _new($subhandle);

    return 0 unless $_[1];
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item Create

    $reg_obj->Create($sub_key_name, $new_reg_obj);

Opens the subkey specified by $sub_key_name, returning the new registry
object in $new_reg_obj.  If the specified subkey doesn't exist, it is
created.

=cut

sub Create {
    my $self = shift;
    die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2;

    my ($subkey) = @_;
    my ($result,$subhandle);

    $result = RegCreateKey($self->{'handle'},$subkey,$subhandle);
    $_[1] = _new ($subhandle);

    return 0 unless $_[1];
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item SetValue

    $reg_obj->SetValue($sub_key_name, $type, $value);

Sets the default value for a subkey specified by $sub_key_name.

=cut

sub SetValue {
    my $self = shift;
    die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3;
    my $result = RegSetValue($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item SetValueEx

    $reg_obj->SetValueEx($value_name, $reserved, $type, $value);

Sets the value for the value name identified by $value_name
in the key specified by $reg_obj.

=cut

sub SetValueEx {
    my $self = shift;
    die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4;
    my $result = RegSetValueEx($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item QueryValue

    $reg_obj->QueryValue($sub_key_name, $value);

Gets the default value of the subkey specified by $sub_key_name.

=cut

sub QueryValue {
    my $self = shift;
    die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2;
    my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item QueryKey

    $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values);

Gets information on a key specified by $reg_obj.

=cut

sub QueryKey {
    my $garbage;
    my $self = shift;
    die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)'
        if @_ != 3;

    my $result = RegQueryInfoKey($self->{'handle'}, $_[0],
                     $garbage, $garbage, $_[1],
                     $garbage, $garbage, $_[2],
                     $garbage, $garbage, $garbage, $garbage);

    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item QueryValueEx

    $reg_obj->QueryValueEx($value_name, $type, $value);

Gets the value for the value name identified by $value_name
in the key specified by $reg_obj.

=cut

sub QueryValueEx {
    my $self = shift;
    die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3;
    my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item GetKeys

    my @keys;
    $reg_obj->GetKeys(\@keys);

Populates the supplied array reference with the names of all the keys
within the registry object $reg_obj.

=cut

sub GetKeys {
    my $self = shift;
    die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY';

    my ($result, $i, $keyname);
    $keyname = "DummyVal";
    $i = 0;
    $result = 1;

    while ( $result ) {
    $result = RegEnumKey( $self->{'handle'},$i++, $keyname );
    if ($result) {
        push( @{$_[0]}, $keyname );
    }
    }
    return(1);
}

=item GetValues

    my %values;
    $reg_obj->GetValues(\%values);

Populates the supplied hash reference with entries of the form

    $value_name => [ $value_name, $type, $data ]

for each value in the registry object $reg_obj.

=cut

sub GetValues {
    my $self = shift;
    die 'usage: $obj->GetValues($hashref)' if @_ != 1;

    my ($result,$name,$type,$data,$i);
    $name = "DummyVal";
    $i = 0;
    while ( $result=RegEnumValue( $self->{'handle'},
                  $i++,
                  $name,
                  undef,
                  $type,
                  $data ))
    {
    $_[0]->{$name} = [ $name, $type, $data ];
    }
    return(1);
}

=item DeleteKey

    $reg_obj->DeleteKey($sub_key_name);

Deletes a subkey specified by $sub_key_name from the registry.

=cut

sub DeleteKey {
    my $self = shift;
    die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1;
    my $result = RegDeleteKey($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item DeleteValue

    $reg_obj->DeleteValue($value_name);

Deletes a value identified by $value_name from the registry.

=cut

sub DeleteValue {
    my $self = shift;
    die 'usage: $obj->DeleteValue($value_name)' if @_ != 1;
    my $result = RegDeleteValue($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item Save

    $reg_obj->Save($filename);

Saves the hive specified by $reg_obj to a file.

=cut

sub Save {
    my $self = shift;
    die 'usage: $obj->Save($filename)' if @_ != 1;
    my $result = RegSaveKey($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item Load

    $reg_obj->Load($sub_key_name, $file_name);

Loads a key specified by $sub_key_name from a file.

=cut

sub Load {
    my $self = shift;
    die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2;
    my $result = RegLoadKey($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

=item UnLoad

    $reg_obj->Unload($sub_key_name);

Unloads a registry hive.

=cut

sub UnLoad {
    my $self = shift;
    die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1;
    my $result = RegUnLoadKey($self->{'handle'}, @_);
    $! = Win32::GetLastError() unless $result;
    return $result;
}

1;
__END__