diff options
Diffstat (limited to 'Master/tlpkg')
-rw-r--r-- | Master/tlpkg/TeXLive/TLUtils.pm | 58 | ||||
-rw-r--r-- | Master/tlpkg/TeXLive/TLWinGoo.pm | 393 |
2 files changed, 250 insertions, 201 deletions
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm index 547f9a70edc..28e0baab29d 100644 --- a/Master/tlpkg/TeXLive/TLUtils.pm +++ b/Master/tlpkg/TeXLive/TLUtils.pm @@ -1515,9 +1515,9 @@ sub do_postaction { } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) { $ret &&= _do_postaction_fileassoc($how, $do_fileassocs, $tlpobj, $1); next; - } elsif ($pa =~ m/\s*appreg\s+(.*)\s*$/) { + } elsif ($pa =~ m/\s*progid\s+(.*)\s*$/) { next unless $do_fileassocs; - $ret &&= _do_postaction_application($how, $tlpobj, $1); + $ret &&= _do_postaction_progid($how, $tlpobj, $1); } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) { next unless $do_script; $ret &&= _do_postaction_script($how, $tlpobj, $1); @@ -1611,63 +1611,37 @@ sub _do_postaction_filetype { return 1; } -sub _do_postaction_application { +sub _do_postaction_progid { my ($how, $tlpobj, $pa) = @_; return 1 unless win32(); my ($errors, %keyval) = - parse_into_keywords($pa, qw/prog cmd exts/); + parse_into_keywords($pa, qw/extension filetype/); if ($errors) { tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); return 0; } - # prog - if (!defined($keyval{'prog'})) { - tlwarn("prog of appreg postaction not given\n"); + # name can be an arbitrary string + if (!defined($keyval{'extension'})) { + tlwarn("extension of progid postaction not given\n"); return 0; } - my $prog = $keyval{'prog'}; + my $extension = $keyval{'extension'}; - if (!defined($keyval{'cmd'})) { - tlwarn("cmd of appreg postaction not given\n"); + # cmd can be an arbitrary string + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of progid postaction not given\n"); return 0; } - my $cmd = $keyval{'cmd'}; - - my $exts_arr = []; - my $e; - my $exts = ''; - if (!defined($keyval{'exts'})) { - tlwarn("exts of appreg postaction not given\n"); - } else { - $exts = $keyval{'exts'}; - foreach $e (split /\|/, $exts) { - if ($e =~ /^\./) { - push @$exts_arr, $e; - } else { - tlwarn("Invalid extension $e for $prog ignored\n"); - } - } - } - - my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; - chomp($texdir); - my $texdir_bsl = conv_to_w32_path($texdir); - $cmd =~ s!^("?)TEXDIR/!$1$texdir/!g; + my $filetype = $keyval{'filetype'}; - &log("postaction $how appreg for " . $tlpobj->name . - ": $prog, $cmd, $exts\n"); + &log("postaction $how progid for " . $tlpobj->name . + ": $extension, $filetype\n"); if ($how eq "install") { - TeXLive::TLWinGoo::register_application($prog, $cmd, $exts_arr); - foreach $e (@$exts_arr) { - TeXLive::TLWinGoo::add_to_openwithlist($e, $prog); - } + TeXLive::TLWinGoo::add_to_progids($extension, $filetype); } elsif ($how eq "remove") { - TeXLive::TLWinGoo::unregister_application($prog); - foreach $e (@$exts_arr) { - TeXLive::TLWinGoo::remove_from_openwithlist($e, $prog); - } + TeXLive::TLWinGoo::remove_from_progids($extension, $filetype); } else { tlwarn("Unknown mode $how\n"); return 0; diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm index 8a4cc591f96..2c6c15d2289 100644 --- a/Master/tlpkg/TeXLive/TLWinGoo.pm +++ b/Master/tlpkg/TeXLive/TLWinGoo.pm @@ -49,14 +49,14 @@ C<TeXLive::TLWinGoo> -- Additional utilities for Windows TeXLive::TLWinGoo::setenv_reg($env_var, $env_data); TeXLive::TLWinGoo::unsetenv_reg($env_var); TeXLive::TLWinGoo::adjust_reg_path_for_texlive($action, $texbindir, $mode); + TeXLive::TLWinGoo::add_to_progids($ext, $filetype); + TeXLive::TLWinGoo::remove_from_progids($ext, $filetype); TeXLive::TLWinGoo::register_extension($mode, $extension, $file_type); TeXLive::TLWinGoo::unregister_extension($mode, $extension); TeXLive::TLWinGoo::register_file_type($file_type, $command); TeXLive::TLWinGoo::unregister_file_type($file_type); TeXLive::TLWinGoo::register_application($prog, $cmd, $exts); - TeXLive::TLWinGoo::unregister_application($prog); - TeXLive::TLWinGoo::add_to_openwithlist($ext, $prog); - TeXLive::TLWinGoo::remove_from_openwithlist($ext, $prog); + TeXLive::TLWinGoo::unregister_application($prog, $cmd); =head2 ACTIVATING CHANGES IMMEDIATELY @@ -103,14 +103,12 @@ BEGIN { &setenv_reg &unsetenv_reg &adjust_reg_path_for_texlive + &add_to_progids + &remove_from_progids ®ister_extension &unregister_extension ®ister_file_type &unregister_file_type - ®ister_application - &unregister_application - &add_to_openwithlist - &remove_from_openwithlist &broadcast_env &update_assocs &shell_folder @@ -135,7 +133,7 @@ BEGIN { require Win32::API; require Win32::TieRegistry; Win32::TieRegistry->import( qw( $Registry - REG_SZ REG_EXPAND_SZ KEY_READ KEY_WRITE KEY_ALL_ACCESS + REG_SZ REG_EXPAND_SZ REG_NONE KEY_READ KEY_WRITE KEY_ALL_ACCESS KEY_ENUMERATE_SUB_KEYS ) ); $Registry->Delimiter('/'); $Registry->ArrayValues(0); @@ -553,8 +551,22 @@ sub adjust_reg_path_for_texlive { ### helper subs for file types ### -# delete a registry key recursively. -# the key parameter should be a string, not a registry object. +# merge recursive hashes such as occur in the registry + +sub hash_merge { + my $target = shift; # the recursive hash ref to be modified by $mods + my $mods = shift; # the recursive hash ref to be merged into $target + my $k; + foreach $k (keys %$mods) { + if (ref($target->{$k}) eq 'HASH' and ref($mods->{$k}) eq 'HASH') { + hash_merge($target->{$k}, $mods->{$k}); + } else { + $target->{$k} = $mods->{$k}; + } + } +} + +# prevent catastrophies during testing; not to be used in production code sub getans { my $prompt = shift; @@ -565,6 +577,9 @@ sub getans { die "Aborting as requested"; } +# delete a registry key recursively. +# the key parameter should be a string, not a registry object. + sub reg_delete_recurse { my $parent = shift; my $childname = shift; @@ -573,17 +588,18 @@ sub reg_delete_recurse { my $child; if ($childname !~ '^/') { # subkey $child = $parent->Open ($childname, {Access => KEY_ALL_ACCESS()}); - return unless $child; + return 1 unless defined($child); foreach my $v (keys %$child) { if ($v =~ '^/') { # value delete $child->{$v}; } else { # subkey - reg_delete_recurse ($child, $v); + return 0 unless reg_delete_recurse ($child, $v); } } - delete $child->{'/'}; + #delete $child->{'/'}; } delete $parent->{$childname}; + return 1; } sub cu_root { @@ -604,22 +620,15 @@ sub lm_root { return $k; } -# write a registry key or not, depending on -# mode, existing keys and privilege level +# write a registry key under HKCU or HKLM, depending on privilege level sub do_write_regkey { - my $mode = shift; my $keypath = shift; # modulo cu/lm - my $keyhash = shift; # ref to a possibly nested hash + my $keyhash = shift; # ref to a possibly nested hash; empty hash allowed die "No regkey specified" unless $keypath && defined($keyhash); # for error reporting: my $hivename = $is_admin ? 'HKLM' : 'HKCU'; - if ($mode == 0) { - ddebug "Mode 0: not writing $hivename/$keypath key\n"; - return 1; - } - # split into parent and final subkey # remove initial slash from parent # ensure subkey ends with slash @@ -627,7 +636,7 @@ sub do_write_regkey { if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { ($parentpath, $keyname) = ($1, $2); $keyname .= '/'; - debug "key - $hivename - $parentpath - $keyname\n"; + debug ("key - $hivename - $parentpath - $keyname\n"); } else { die "Cannot determine final component of $keypath"; } @@ -635,26 +644,9 @@ sub do_write_regkey { my $cu_key = cu_root(); my $lm_key = lm_root(); # cu_root() and lm_root() already die upon failure - my $do_create = 1; - if ($mode == 1) { - if ($is_admin) { - if ($lm_key->{$keypath}) { - $do_create = 0; - debug "Not writing HKLM/$keypath because already present\n"; - } - } else { - if ($cu_key->{$keypath}) { - $do_create = 0; - debug "Not writing HKCU/$keypath because already present\n"; - } elsif ($lm_key->{$keypath}) { - $do_create = 0; - debug "Not writing HKCU/$keypath because ". - "HKLM/$keypath already present\n"; - } - } - }; - return 1 unless $do_create; my $parentkey; + + # make sure parent exists if ($is_admin) { $parentkey = $lm_key->Open($parentpath); if (!$parentkey) { @@ -671,49 +663,38 @@ sub do_write_regkey { tlwarn "Cannot create parent of $hivename/$keypath\n"; return 0; } - if ($parentkey->{$keyname}) {reg_delete_recurse($parentkey, $keyname);} - $parentkey->{$keyname} = $keyhash; + + # create or merge key + if ($parentkey->{$keyname}) { + hash_merge($parentkey->{$keyname}, $keyhash); + } else { + $parentkey->{$keyname} = $keyhash; + } if (!$parentkey->{$keyname}) { - tlwarn "Failure to create HKLM/$keypath\n"; + tlwarn "Failure to create $hivename/$keypath\n"; return 0; } if ($is_admin and $cu_key->{$keypath}) { # delete possibly conflicting cu key - reg_delete_recurse ($cu_key->{$parentpath}, $keyname); - } - if (!$parentkey) { - $parentkey = $cu_key->CreateKey($parentpath); - if (!$parentkey) { - tlwarn "Cannot create parentpath of HKCU/$keypath\n"; - return 0; - } - } - if ($parentkey->{$keyname}) {reg_delete_recurse($parentkey, $keyname);} - $parentkey->{$keyname} = $keyhash; - if (!$parentkey->{$keyname}) { - tlwarn "Failure to create $hivename/$keypath\n"; - return 0; + tlwarn "Failure to delete $hivename/$keypath key\n" unless + reg_delete_recurse ($cu_key->{$parentpath}, $keyname); } return 1; } sub do_remove_regkey { - my $mode = shift; - my $keypath = shift; - my $testhash = shift; - # hashref of subkey/value => data pairs - # mode 1: if any is present and does not match, then do not remove - # ATM we assume REG_SZ data - # In future, a we might use a subroutine reference instead. + my $keypath = shift; # key or value my $hivename = $is_admin ? 'HKLM' : 'HKCU'; - if ($mode == 0) { - ddebug "Mode 0: not removing $hivename/$keypath key\n"; - return 1; - } - - my ($parentpath, $keyname); - if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { + my $parentpath = ""; + my $keyname = ""; + my $valname = ""; + # two successive delimiters: value. + # *? = non-greedy match: want FIRST double delimiter + if ($keypath =~ /^(.*?\/)(\/.*)$/) { + ($parentpath, $valname) = ($1, $2); + $parentpath =~ s!^/!!; # remove leading delimiter + } elsif ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { ($parentpath, $keyname) = ($1, $2); $keyname .= '/'; } else { @@ -722,12 +703,6 @@ sub do_remove_regkey { my $cu_key = cu_root(); my $lm_key = lm_root(); - if ($is_admin) { - return 0 unless $lm_key; - } else { - return 0 unless $cu_key; - } - my $do_remove = 1; my ($parentkey, $k, $skv, $d); if ($is_admin) { $parentkey = $lm_key->Open($parentpath); @@ -735,40 +710,103 @@ sub do_remove_regkey { $parentkey = $cu_key->Open($parentpath); } if (!$parentkey) { - $do_remove = 0; - debug "$hivename/$parentpath not present or not writable so not removed\n"; + debug ("$hivename/$parentpath not present or not writable". + " so $keypath not removed\n"); return 1; } - if ($mode == 1) { - $k = $parentkey->{$keyname}; - if ($k) { - if ($testhash) {foreach $skv (keys %$testhash) { - $d = $k->{$keyname.$skv}; - if ($d and $d ne $test->{$skv}) { - $do_remove = 0; - debug "$hivename/$keypath modified; not deleting\n"; - last; - } - }} - } else { - $do_remove = 0; - debug "$hivename/$keypath not present or not writable so not removed\n"; + if ($keyname) { + #getans("Deleting $parentpath$keyname regkey? "); + reg_delete_recurse($parentkey, $keyname); + if ($parentkey->{$keyname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + reg_delete_recurse($cu_key->{$parentpath}, $keyname); + if ($cu_key->{$parentpath}->{$keyname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } + } + } else { + delete $parentkey->{$valname}; + if ($parentkey->{$valname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + delete $cu_key->{$parentpath}->{$valname}; + if ($cu_key->{$parentpath}->{$valname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } } - }; - return 1 unless $do_remove; - #getans("Deleting $parentpath$keyname regkey? "); - reg_delete_recurse($parentkey, $keyname); - if ($parentkey->{$keyname}) { - tlwarn "Failure to delete $hivename/$keypath\n"; - return 0; - } - if ($is_admin and $cu_key->{$parentpath}) { - reg_delete_recurse($cu_key->{$parentpath}, $keyname); - # no errorchecking this once } return 1; } +sub current_valdata { + my $value_path = shift; + die "Illegal value path $value_path" + unless $value_path =~ /\/\//; + my $valdata = ""; + if ($is_admin) { + $valdata = lm_root()->{"Software/Classes/$value_path"}; + } else { + $valdata = $Registry->{"Classes/$value_path"}; + } + $valdata = "" unless defined($valdata); + return $valdata; +} + +=pod + +=item C<add_to_progids($ext, $filetype)> + +Add $filetype to the list of programs which open $ext files + +=cut + +sub add_to_progids { + my $ext = shift; + my $filetype = shift; + $Registry->ArrayValues(1); + do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + {"/$filetype" => [0, REG_NONE()]}); + $Registry->ArrayValues(0); +} + +=pod + +=item C<remove_from_progids($ext, $filetype)> + +Remove $filetype from the list of programs which open $ext files + +=cut + +sub remove_from_progids { + my $ext = shift; + my $filetype = shift; + 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; + if ($is_admin) { + $is_active = 1 if ($file_type and + lm_root()->{"Software/Classes/$file_type/shell/"}); + } else { + $is_active = 1 if ($file_type and + $Registry->{"Classes/$file_type/shell/"}); + } + $file_type = "" unless $is_active; + return $file_type; +} + =pod =item C<register_extension($mode, $extension, $file_type)> @@ -776,29 +814,50 @@ sub do_remove_regkey { Add registry entry to associate $extension with $file_type. Slashes are flipped where necessary. -If $mode is 0, nothing is actually done. If $mode is 1, only not-present -keys of keys that are matching the given key are (re)created. If $mode -is 2 then keys are (re)created in any case. +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 that Windows often creates filetypes for +extensions automatically, it seems better to ignore filetypes +without actions. + +For $mode 2, the filetype is always overwritten. =cut sub register_extension { my $mode = shift; + return 1 if $mode == 0; my $extension = shift; # ensure leading dot $extension = '.'.$extension unless $extension =~ /^\./; $extension = lc($extension); - my $file_type = shift; - debug("Linking $extension to $file_type\n"); - - my $regkey = {'/' => $file_type}; - do_write_regkey($mode, "Software/Classes/$extension/", $regkey); + my $regkey; + + my $old_file_type = active_file_type($extension); + if ($old_file_type and $old_file_type ne $file_type) { + if ($mode == 1) { + debug ("Not overwriting $old_file_type with $file_type for $extension\n"); + debug ("Adding to OpenWithProgIds instead\n"); + add_to_progids ($extension, $file_type); + } else { + debug("Linking $extension to $file_type\n"); + add_to_progids ($extension, $old_file_type); + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey); + remove_from_progids($extension, $file_type); + } + } else { + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey); + } } =pod -=item C<unregister_extension($mode, $extension, $filetype)> +=item C<unregister_extension($mode, $extension, $file_type)> Reversal of register_extension. @@ -807,15 +866,21 @@ Reversal of register_extension. sub unregister_extension { # we don't error check; we just do the best we can. my $mode = shift; - # mode 0: continue anyhow and let do_remove_regkey - # bail out with a debug message. + return 1 if $mode == 0; + # mode 1 and 2 treated identically: + # only unregister if the value is as expected my $extension = shift; - my $filetype = shift; + my $file_type = shift; $extension = '.'.$extension unless $extension =~ /^\./; - debug("unregistering $extension\n"); - - $testhash = {"/" => $filetype}; - do_remove_regkey($mode, "Software/Classes/".$extension, $testhash); + remove_from_progids($extension, $file_type); + my $old_file_type = current_valdata("$extension//"); + if ($old_file_type ne $file_type) { + debug("Filetype $extension now $old_file_type; not ours, so not removed\n"); + return 1; + } else { + debug("unregistering extension $extension\n"); + do_remove_regkey("Software/Classes/$extension//"); + } } =pod @@ -842,7 +907,7 @@ sub register_file_type { } } }; - do_write_regkey(2, "Software/Classes/$file_type", $keyhash); + do_write_regkey("Software/Classes/$file_type", $keyhash); } =pod @@ -855,9 +920,11 @@ Reversal of register_script_type. sub unregister_file_type { # we don't error check; we just do the best we can. + # All our filetypes start with 'TL.' so we consider them + # our own even if they have been tampered with. my $file_type = shift; debug ("unregistering $file_type\n"); - do_remove_regkey(2, "Software/Classes/$file_type/"); + do_remove_regkey("Software/Classes/$file_type/"); } =pod @@ -876,8 +943,6 @@ sub register_application { my $hsh; foreach my $e (@$exts) {$hsh->{"/$e"} = "";} - #my $prog = TeXLive::TLUtils::basename($path); - # $cmd = "\"$path\" \"%1\""; # done by caller $cmd =~ s!/!\\!g; my $keyhash = { "shell/" => { @@ -889,49 +954,56 @@ sub register_application { }, "SupportedTypes" => $hsh }; - do_write_regkey(2, "Software/Classes/Applications/$prog", $keyhash); + do_write_regkey("Software/Classes/Applications/$prog", $keyhash); } =pod -=item C<unregister_application($prog)> +=item C<unregister_application($prog, $cmd)> -Reversal of register_application +Reversal of register_application. Return value: key no longer exists. =cut sub unregister_application { my $prog = shift; - do_remove_regkey(2, "Software/Classes/Applications/$prog"); -} - -=pod - -=item C<add_to_openwithlist($ext, $prog)> - -Add $prog to the list of programs which open $ext files - -=cut - -sub add_to_openwithlist { - my $ext = shift; - my $prog = shift; - do_write_regkey(2, "Software/Classes/$ext/OpenWithList/$prog", {}); -} - -=pod - -=item C<remove_from_openwithlist($ext, $prog)> - -Remove $prog from the list of programs which open $ext files - -=cut - -sub remove_from_openwithlist { - my $ext = shift; - my $prog = shift; - do_remove_regkey(2, "Software/Classes/$ext/OpenWithList/$prog"); + my $cmd = shift; + my $hive = $is_admin ? "LMachine" : "CUser"; + my $regpath = "Software/Classes/Applications/$prog"; + my $regkey = $Registry->{"$hive/$regpath/"}; + return 1 unless $regkey; + my $current_cmd = $regkey->{"shell/open/command//"}; + do_remove_regkey("$hive/$regpath/") if $cmd eq $current_cmd; + return !defined($regkey); } +# +#=pod +# +#=item C<add_to_openwithlist($ext, $prog)> +# +#Add $prog to the list of programs which open $ext files +# +#=cut +# +#sub add_to_openwithlist { +# my $ext = shift; +# my $prog = shift; +# do_write_regkey("Software/Classes/$ext/OpenWithList/$prog", {}); +#} +# +#=pod +# +#=item C<remove_from_openwithlist($ext, $prog)> +# +#Remove $prog from the list of programs which open $ext files +# +#=cut +# +#sub remove_from_openwithlist { +# my $ext = shift; +# my $prog = shift; +# do_remove_regkey("Software/Classes/$ext/OpenWithList/$prog"); +#} =pod @@ -1254,8 +1326,11 @@ sub unregister_uninstaller { "/software/microsoft/windows/currentversion/uninstall/"; my $regkey_uninst = $Registry->Open($regkey_uninst_path, {Access => KEY_ALL_ACCESS()}); - reg_delete_recurse($regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/") + reg_delete_recurse( + $regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/") if $regkey_uninst; + tlwarn "Failure to unregister uninstaller\n" if + $regkey_uninst->{"TeXLive$::TeXLive::TLConfig::ReleaseYear/"}; } =pod |