home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _a713cdc3d7ce9e74d34bc92e0ffd9862 < prev    next >
Encoding:
Text File  |  2000-03-15  |  10.8 KB  |  442 lines
  1. package Win32::Registry;
  2. #######################################################################
  3. #Perl Module for Registry Extensions
  4. # This module creates an object oriented interface to the Win32
  5. # Registry.
  6. #
  7. # NOTE: This package exports the following "key" objects to
  8. # the main:: name space.
  9. #
  10. # $main::HKEY_CLASSES_ROOT
  11. # $main::HKEY_CURRENT_USER
  12. # $main::HKEY_LOCAL_MACHINE
  13. # $main::HKEY_USERS
  14. # $main::HKEY_PERFORMANCE_DATA
  15. # $main::HKEY_CURRENT_CONFIG
  16. # $main::HKEY_DYN_DATA
  17. #
  18. #######################################################################
  19.  
  20. require Exporter;
  21. require DynaLoader;
  22. use Win32::WinError;
  23.  
  24. $VERSION = '0.062';
  25.  
  26. @ISA= qw( Exporter DynaLoader );
  27. @EXPORT = qw(
  28.     HKEY_CLASSES_ROOT
  29.     HKEY_CURRENT_USER
  30.     HKEY_LOCAL_MACHINE
  31.     HKEY_PERFORMANCE_DATA
  32.     HKEY_CURRENT_CONFIG
  33.     HKEY_DYN_DATA
  34.     HKEY_USERS
  35.     KEY_ALL_ACCESS
  36.     KEY_CREATE_LINK
  37.     KEY_CREATE_SUB_KEY
  38.     KEY_ENUMERATE_SUB_KEYS
  39.     KEY_EXECUTE
  40.     KEY_NOTIFY
  41.     KEY_QUERY_VALUE
  42.     KEY_READ
  43.     KEY_SET_VALUE
  44.     KEY_WRITE
  45.     REG_BINARY
  46.     REG_CREATED_NEW_KEY
  47.     REG_DWORD
  48.     REG_DWORD_BIG_ENDIAN
  49.     REG_DWORD_LITTLE_ENDIAN
  50.     REG_EXPAND_SZ
  51.     REG_FULL_RESOURCE_DESCRIPTOR
  52.     REG_LEGAL_CHANGE_FILTER
  53.     REG_LEGAL_OPTION
  54.     REG_LINK
  55.     REG_MULTI_SZ
  56.     REG_NONE
  57.     REG_NOTIFY_CHANGE_ATTRIBUTES
  58.     REG_NOTIFY_CHANGE_LAST_SET
  59.     REG_NOTIFY_CHANGE_NAME
  60.     REG_NOTIFY_CHANGE_SECURITY
  61.     REG_OPENED_EXISTING_KEY
  62.     REG_OPTION_BACKUP_RESTORE
  63.     REG_OPTION_CREATE_LINK
  64.     REG_OPTION_NON_VOLATILE
  65.     REG_OPTION_RESERVED
  66.     REG_OPTION_VOLATILE
  67.     REG_REFRESH_HIVE
  68.     REG_RESOURCE_LIST
  69.     REG_RESOURCE_REQUIREMENTS_LIST
  70.     REG_SZ
  71.     REG_WHOLE_HIVE_VOLATILE
  72. );
  73.  
  74. @EXPORT_OK = qw(
  75.     RegCloseKey
  76.     RegConnectRegistry
  77.     RegCreateKey
  78.     RegCreateKeyEx
  79.     RegDeleteKey
  80.     RegDeleteValue
  81.     RegEnumKey
  82.     RegEnumValue
  83.     RegFlushKey
  84.     RegGetKeySecurity
  85.     RegLoadKey
  86.     RegNotifyChangeKeyValue
  87.     RegOpenKey
  88.     RegOpenKeyEx
  89.     RegQueryInfoKey
  90.     RegQueryValue
  91.     RegQueryValueEx
  92.     RegReplaceKey
  93.     RegRestoreKey
  94.     RegSaveKey
  95.     RegSetKeySecurity
  96.     RegSetValue
  97.     RegSetValueEx
  98.     RegUnLoadKey
  99. );
  100. $EXPORT_TAGS{ALL}= \@EXPORT_OK;
  101.  
  102. bootstrap Win32::Registry;
  103.  
  104. sub import
  105. {
  106.     my( $pkg )= shift;
  107.     if (  $_[0] && "Win32" eq $_[0]  ) {
  108.     Exporter::export( $pkg, "Win32", @EXPORT_OK );
  109.     shift;
  110.     }
  111.     Win32::Registry->export_to_level( 1+$Exporter::ExportLevel, $pkg, @_ );
  112. }
  113.  
  114. #######################################################################
  115. # This AUTOLOAD is used to 'autoload' constants from the constant()
  116. # XS function.  If a constant is not found then control is passed
  117. # to the AUTOLOAD in AutoLoader.
  118.  
  119. sub AUTOLOAD {
  120.     my($constname);
  121.     ($constname = $AUTOLOAD) =~ s/.*:://;
  122.     #reset $! to zero to reset any current errors.
  123.     $!=0;
  124.     my $val = constant($constname, @_ ? $_[0] : 0);
  125.     if ($! != 0) {
  126.     if ($! =~ /Invalid/) {
  127.         $AutoLoader::AUTOLOAD = $AUTOLOAD;
  128.         goto &AutoLoader::AUTOLOAD;
  129.     }
  130.     else {
  131.         ($pack,$file,$line) = caller;
  132.         die "Your vendor has not defined Win32::Registry macro $constname, used at $file line $line.";
  133.     }
  134.     }
  135.     eval "sub $AUTOLOAD { $val }";
  136.     goto &$AUTOLOAD;
  137. }
  138.  
  139. #######################################################################
  140. # _new is a private constructor, not intended for public use.
  141. #
  142.  
  143. sub _new
  144. {
  145.     my $self;
  146.     if ($_[0]) {
  147.     $self->{'handle'} = $_[0];
  148.     bless $self;
  149.     }
  150.     $self;
  151. }
  152.  
  153. #define the basic registry objects to be exported.
  154. #these had to be hardwired unfortunately.
  155. # XXX Yuck!
  156.  
  157. $main::HKEY_CLASSES_ROOT    = _new(&HKEY_CLASSES_ROOT);
  158. $main::HKEY_CURRENT_USER    = _new(&HKEY_CURRENT_USER);
  159. $main::HKEY_LOCAL_MACHINE    = _new(&HKEY_LOCAL_MACHINE);
  160. $main::HKEY_USERS        = _new(&HKEY_USERS);
  161. $main::HKEY_PERFORMANCE_DATA    = _new(&HKEY_PERFORMANCE_DATA);
  162. $main::HKEY_CURRENT_CONFIG    = _new(&HKEY_CURRENT_CONFIG);
  163. $main::HKEY_DYN_DATA        = _new(&HKEY_DYN_DATA);
  164.  
  165.  
  166. #######################################################################
  167. #Open
  168. # creates a new Registry object from an existing one.
  169. # usage: $RegObj->Open( "SubKey",$SubKeyObj );
  170. #               $SubKeyObj->Open( "SubberKey", *SubberKeyObj );
  171.  
  172. sub Open
  173. {
  174.     my $self = shift;
  175.     die 'usage: Open( $SubKey, $ObjRef )' if @_ != 2;
  176.     
  177.     my ($subkey) = @_;
  178.     my ($result,$subhandle);
  179.  
  180.     $result = RegOpenKey($self->{'handle'},$subkey,$subhandle);
  181.     $_[1] = _new( $subhandle );
  182.     
  183.     return 0 unless $_[1];
  184.     $! = Win32::GetLastError() unless $result;
  185.     return $result;
  186. }
  187.  
  188. #######################################################################
  189. #Close
  190. # close an open registry key.
  191. #
  192. sub Close
  193. {
  194.     my $self = shift;
  195.     die "usage: Close()" if @_ != 0;
  196.  
  197.     my $result = RegCloseKey($self->{'handle'});
  198.     if ($result) {
  199.     delete $self->{'handle'};
  200.     }
  201.     else {
  202.     $! = Win32::GetLastError();
  203.     }
  204.     return $result;
  205. }
  206.  
  207. sub DESTROY {
  208.     my $self = shift;
  209.     return unless exists $self->{'handle'};
  210.     RegCloseKey($self->{'handle'});
  211. }
  212.  
  213. #######################################################################
  214. #Connect
  215. # connects to a remote Registry object, returning it in $ObjRef.
  216. # returns false if it fails.
  217. # usage: $RegObj->Connect( $NodeName, $ObjRef );
  218.  
  219. sub Connect
  220. {
  221.     my $self = shift;
  222.     die 'usage: Connect( $NodeName, $ObjRef )' if @_ != 2;
  223.      
  224.     my ($node) = @_;
  225.     my ($result,$subhandle);
  226.  
  227.     $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle);
  228.     $_[1] = _new( $subhandle );
  229.  
  230.     return 0 unless $_[1];
  231.     $! = Win32::GetLastError() unless $result;
  232.     return $result;
  233. }  
  234.  
  235. #######################################################################
  236. #Create
  237. # open a subkey.  If it doesn't exist, create it.
  238. #
  239.  
  240. sub Create
  241. {
  242.     my $self = shift;
  243.     die 'usage: Create( $SubKey,$ScalarRef )' if @_ != 2;
  244.  
  245.     my ($subkey) = @_;
  246.     my ($result,$subhandle);
  247.  
  248.     $result = RegCreateKey($self->{'handle'},$subkey,$subhandle);
  249.     $_[1] = _new ( $subhandle );
  250.  
  251.     return 0 unless $_[1];
  252.     $! = Win32::GetLastError() unless $result;
  253.     return $result;
  254. }
  255.  
  256. #######################################################################
  257. #SetValue
  258. # SetValue sets a value in the current key.
  259. #
  260.  
  261. sub SetValue
  262. {
  263.     my $self = shift;
  264.     die 'usage: SetValue($SubKey,$Type,$value )' if @_ != 3;
  265.     my $result = RegSetValue( $self->{'handle'}, @_);
  266.     $! = Win32::GetLastError() unless $result;
  267.     return $result;
  268. }
  269.  
  270. sub SetValueEx
  271. {
  272.     my $self = shift;
  273.     die 'usage: SetValueEx( $SubKey,$Reserved,$type,$value )' if @_ != 4;
  274.     my $result = RegSetValueEx( $self->{'handle'}, @_);
  275.     $! = Win32::GetLastError() unless $result;
  276.     return $result;
  277. }
  278.  
  279. #######################################################################
  280. #QueryValue  and QueryKey
  281. # QueryValue gets information on a value in the current key.
  282. # QueryKey "    "       "       "  key  "       "       "       
  283.  
  284. sub QueryValue
  285. {
  286.     my $self = shift;
  287.     die 'usage: QueryValue( $SubKey,$valueref )' if @_ != 2;
  288.     my $result = RegQueryValue( $self->{'handle'}, @_);
  289.     $! = Win32::GetLastError() unless $result;
  290.     return $result;
  291. }
  292.  
  293. sub QueryKey
  294. {
  295.     my $garbage;
  296.     my $self = shift;
  297.     die 'usage: QueryKey( $classref, $numberofSubkeys, $numberofVals )'
  298.         if @_ != 3;
  299.  
  300.     my $result = RegQueryInfoKey($self->{'handle'}, $_[0],
  301.                      $garbage, $garbage, $_[1],
  302.                      $garbage, $garbage, $_[2],
  303.                      $garbage, $garbage, $garbage, $garbage);
  304.  
  305.     $! = Win32::GetLastError() unless $result;
  306.     return $result;
  307. }
  308.  
  309. #######################################################################
  310. #QueryValueEx
  311. # QueryValueEx gets information on a value in the current key.
  312.  
  313. sub QueryValueEx
  314. {
  315.     my $self = shift;
  316.     die 'usage: QueryValueEx( $SubKey,$type,$valueref )' if @_ != 3;
  317.     my $result = RegQueryValueEx( $self->{'handle'}, $_[0], NULL, $_[1], $_[2] );
  318.     $! = Win32::GetLastError() unless $result;
  319.     return $result;
  320. }
  321.  
  322. #######################################################################
  323. #GetKeys
  324. #Note: the list object must be passed by reference: 
  325. #       $myobj->GetKeys( \@mylist )
  326. sub GetKeys
  327. {
  328.     my $self = shift;
  329.     die 'usage: GetKeys( $arrayref )' if @_ != 1 or ref($_[0]) ne 'ARRAY';
  330.  
  331.     my ($result, $i, $keyname);
  332.     $keyname = "DummyVal";
  333.     $i = 0;
  334.     $result = 1;
  335.     
  336.     while ( $result ) {
  337.     $result = RegEnumKey( $self->{'handle'},$i++, $keyname );
  338.     if ($result) {
  339.         push( @{$_[0]}, $keyname );
  340.     }
  341.     }
  342.     return(1);
  343. }
  344.  
  345. #######################################################################
  346. #GetValues
  347. # GetValues creates a hash containing 'name'=> ( name,type,data )
  348. # for each value in the current key.
  349.  
  350. sub GetValues
  351. {
  352.     my $self = shift;
  353.     die 'usage: GetValues( $hashref )' if @_ != 1;
  354.  
  355.     my ($result,$name,$type,$data,$i);
  356.     $name = "DummyVal";
  357.     $i = 0;
  358.     while ( $result=RegEnumValue( $self->{'handle'},
  359.                   $i++,
  360.                   $name,
  361.                   NULL,
  362.                   $type,
  363.                   $data ))
  364.     {
  365.     $_[0]->{$name} = [ $name, $type, $data ];
  366.     }
  367.     return(1);
  368. }
  369.  
  370. #######################################################################
  371. #DeleteKey
  372. # delete a key from the registry.
  373. #  eg: $CLASSES_ROOT->DeleteKey( "KeyNameToDelete");
  374. #
  375.  
  376. sub DeleteKey
  377. {
  378.     my $self = shift;
  379.     die 'usage: DeleteKey( $SubKey )' if @_ != 1;
  380.     my $result = RegDeleteKey($self->{'handle'}, @_);
  381.     $! = Win32::GetLastError() unless $result;
  382.     return $result;
  383. }
  384.  
  385. #######################################################################
  386. #DeleteValue
  387. # delete a value from the current key in the registry
  388. #  $CLASSES_ROOT->DeleteValue( "\000" );
  389.  
  390. sub DeleteValue
  391. {
  392.     my $self = shift;
  393.     die 'usage: DeleteValue( $SubKey )' if @_ != 1;
  394.     my $result = RegDeleteValue($self->{'handle'}, @_);
  395.     $! = Win32::GetLastError() unless $result;
  396.     return $result;
  397. }
  398.  
  399. #######################################################################
  400. #save
  401. #saves the current hive to a file.
  402. #
  403.  
  404. sub Save
  405. {
  406.     my $self = shift;
  407.     die 'usage: Save( $FileName )' if @_ != 1;
  408.     my $result = RegSaveKey($self->{'handle'}, @_);
  409.     $! = Win32::GetLastError() unless $result;
  410.     return $result;
  411. }
  412.  
  413. #######################################################################
  414. #Load
  415. #loads a saved key from a file.
  416.  
  417. sub Load
  418. {
  419.     my $self = shift;
  420.     die 'usage: Load( $SubKey,$FileName )' if @_ != 2;
  421.     my $result = RegLoadKey($self->{'handle'}, @_);
  422.     $! = Win32::GetLastError() unless $result;
  423.     return $result;
  424. }
  425.  
  426. #######################################################################
  427. #UnLoad
  428. #unloads a registry hive
  429.  
  430. sub UnLoad
  431. {
  432.     my $self = shift;
  433.     die 'usage: UnLoad( $SubKey )' if @_ != 1;
  434.     my $result = RegUnLoadKey($self->{'handle'}, @_);
  435.     $! = Win32::GetLastError() unless $result;
  436.     return $result;
  437. }
  438. #######################################################################
  439.  
  440. 1;
  441. __END__
  442.