From af0965769f2f5c3e24477d00739691e498670cf5 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Fri, 7 Dec 2012 15:41:08 +0000 Subject: Bypass HKCR; flush after registry deletes git-svn-id: svn://tug.org/texlive/trunk@28457 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLWinGoo.pm | 122 +++++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 57 deletions(-) (limited to 'Master') diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm index 63dc07c102a..36e71de0fab 100644 --- a/Master/tlpkg/TeXLive/TLWinGoo.pm +++ b/Master/tlpkg/TeXLive/TLWinGoo.pm @@ -146,6 +146,15 @@ use TeXLive::TLConfig; use TeXLive::TLUtils; TeXLive::TLUtils->import( qw( mkdirhier ) ); +sub reg_debug { + return if ($::opt_verbosity < 1); + my $mess = shift; + my $regerr = Win32API::Registry::regLastError(); + if ($regerr) { + debug("$regerr\n$mess"); + } +} + my $is_win = $^O=~/^MSWin(32|64)$/i; =pod @@ -569,6 +578,9 @@ sub hash_merge { hash_merge($target->{$k}, $mods->{$k}); } else { $target->{$k} = $mods->{$k}; + reg_debug ("at hash merge\n"); + $target->Flush(); + reg_debug ("at hash merge\n"); } } } @@ -595,10 +607,14 @@ sub reg_delete_recurse { my $child; if ($childname !~ '^/') { # subkey $child = $parent->Open ($childname, {Access => KEY_ALL_ACCESS()}); + reg_debug ("at open $childname for all access\n"); return 1 unless defined($child); foreach my $v (keys %$child) { if ($v =~ '^/') { # value delete $child->{$v}; + reg_debug ("at delete $childname/$v\n"); + $child->Flush(); + reg_debug ("at delete $childname/$v\n"); Time::HiRes::usleep(20000); } else { # subkey return 0 unless reg_delete_recurse ($child, $v); @@ -607,6 +623,9 @@ sub reg_delete_recurse { #delete $child->{'/'}; } delete $parent->{$childname}; + reg_debug ("at delete $parentpath$childname\n"); + $parent->Flush(); + reg_debug ("at delete $parentpath$childname\n"); Time::HiRes::usleep(20000); return 1; } @@ -615,6 +634,7 @@ sub cu_root { my $k = $Registry -> Open("CUser", { Access => KEY_ALL_ACCESS(), Delimiter => '/' }); + reg_debug ("at open HKCU for all access\n"); die "Cannot open HKCU for writing" unless $k; return $k; } @@ -624,23 +644,12 @@ sub lm_root { Access => ($is_admin ? KEY_ALL_ACCESS() : KEY_READ()), Delimiter => '/' }); + reg_debug ("at open HKLM\n"); die "Cannot open HKLM for ".($is_admin ? "writing" : "reading") unless $k; return $k; } -sub cl_root { - my $k = $Registry -> Open("Classes", { - Access => KEY_READ(), Delimiter => '/' - }); - die "Cannot open HKCR for reading" unless $k; - return $k; -} - -# write a registry key under HKCU or HKLM, depending on privilege level -# If admin, $remove_cu means to delete the corresponding HKCU entry. -# This parameter is ignored in the non-admin case - sub do_write_regkey { my $keypath = shift; # modulo cu/lm my $keyhash = shift; # ref to a possibly nested hash; empty hash allowed @@ -669,14 +678,18 @@ sub do_write_regkey { # make sure parent exists if ($is_admin) { $parentkey = $lm_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); if (!$parentkey) { # in most cases, this probably shouldn't happen for lm $parentkey = $lm_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); } } else { $parentkey = $cu_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); if (!$parentkey) { $parentkey = $cu_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); } } if (!$parentkey) { @@ -689,6 +702,7 @@ sub do_write_regkey { hash_merge($parentkey->{$keyname}, $keyhash); } else { $parentkey->{$keyname} = $keyhash; + reg_debug ("at creating $keyname\n"); } if (!$parentkey->{$keyname}) { tlwarn "Failure to create $hivename/$keypath\n"; @@ -732,6 +746,7 @@ sub do_remove_regkey { } else { $parentkey = $cu_key->Open($parentpath); } + reg_debug ("at opening $parentpath\n"); if (!$parentkey) { debug ("$hivename/$parentpath not present or not writable". " so $keypath not removed\n"); @@ -753,12 +768,14 @@ sub do_remove_regkey { } } else { delete $parentkey->{$valname}; + reg_debug ("at deleting $valname\n"); if ($parentkey->{$valname}) { tlwarn "Failure to delete $hivename/$keypath\n"; return 0; } if ($is_admin and $cu_key->{$parentpath}) { delete $cu_key->{$parentpath}->{$valname}; + reg_debug ("at deleting $valname\n"); if ($cu_key->{$parentpath}->{$valname}) { tlwarn "Failure to delete HKCU/$keypath\n"; return 0; @@ -768,18 +785,24 @@ sub do_remove_regkey { return 1; } -sub current_valdata { - my $value_path = shift; - die "Illegal value path $value_path" - unless $value_path =~ /\/\//; - my $valdata = ""; +# Effective default value of any key under Classes. +# admin: HKLM; user: HKCU or otherwise HKLM +# Reject if there is no corresponding key under classes +sub current_filetype { + my $extension = shift; + my $filetype; if ($is_admin) { - $valdata = lm_root()->{"Software/Classes/$value_path"}; + $filetype = lm_root()->{"Software/Classes/$extension//"}; # REG_SZ } else { - $valdata = $Registry->{"Classes/$value_path"}; + # Mysterious failures on w7_64 => merge HKLM/HKCU info explicitly + # rather than checking HKCR + $filetype = cu_root()->{"Software/Classes/$extension//"}; + if (!defined($filetype) or ($filetype eq "")) { + $filetype = lm_root()->{"Software/Classes/$extension//"} + }; } - $valdata = "" unless defined($valdata); - return $valdata; + $filetype = "" unless defined($filetype); + return $filetype; } ### now the exported file type functions ### @@ -796,10 +819,12 @@ The associated program shows up in the `open with' right-click menu. sub add_to_progids { my $ext = shift; my $filetype = shift; - $Registry->ArrayValues(1); + #$Registry->ArrayValues(1); + #do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + # {"/$filetype" => [0, REG_NONE()]}); + #$Registry->ArrayValues(0); do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", - {"/$filetype" => [0, REG_NONE()]}); - $Registry->ArrayValues(0); + {"/$filetype" => ""}); } =pod @@ -816,32 +841,6 @@ sub remove_from_progids { do_remove_regkey("Software/Classes/$ext/OpenWithProgIds//$filetype"); } -sub active_file_type { - # current filetype, except - # return empty string if no action associated with it - my $extension = shift; # assume leading dot - my $file_type = current_valdata("$extension//"); - my $is_active = 0; - debug("active_file_type called for $extension and $file_type\n"); - if ($is_admin) { - $is_active = 1 if ($file_type and - lm_root()->{"Software/Classes/$file_type/shell/"}); - } else { - if ($::opt_verbosity) { - my $cmd = cl_root()->{"$file_type/shell/open/command//"}; - if ($cmd) { - debug("Action: $cmd\n"); - } else { - debug("No open command for $extension and $file_type\n"); - } - } - $is_active = 1 if ($file_type and - cl_root()->{"$file_type/shell/"}); - } - $file_type = "" unless $is_active; - return $file_type; -} - =pod =item C @@ -852,11 +851,8 @@ are flipped where necessary. If $mode is 0, nothing is actually done. For $mode 1, the filetype for the extension is preserved, but only -if shell actions are defined for it. This is slightly changed from -previous versions. Because Windows often creates filetypes for -extensions automatically, it seems better to ignore filetypes -without actions. If the old filetype is not overwritten, the new -filetype is added to the openwithprogids list. +if there is a registry key under Classes for it. For $mode>0, +the new filetype is always added to the openwithprogids list. For $mode 2, the filetype is always overwritten. The old filetype moves to the openwithprogids list if necessary. @@ -873,7 +869,19 @@ sub register_extension { my $file_type = shift; my $regkey; - my $old_file_type = active_file_type($extension); + my $old_file_type = current_filetype($extension); + if ($old_file_type) { + if ($is_admin) { + if (not lm_root()->{"Software/Classes/$old_file_type/"}) { + $old_file_type = ""; + } + } else { + if ((not cu_root()->{"Software/Classes/$old_file_type/"}) and + (not lm_root()->{"Software/Classes/$old_file_type/"})) { + $old_file_type = ""; + } + } + } # admin: whether to remove HKCU entry. admin never _writes_ to HKCU my $remove_cu = ($mode == 2) && admin(); # can do the following safely: @@ -913,7 +921,7 @@ sub unregister_extension { my $file_type = shift; $extension = '.'.$extension unless $extension =~ /^\./; remove_from_progids($extension, $file_type); - my $old_file_type = current_valdata("$extension//"); + my $old_file_type = current_filetype("$extension"); if ($old_file_type ne $file_type) { debug("Filetype $extension now $old_file_type; not ours, so not removed\n"); return 1; -- cgit v1.2.3