summaryrefslogtreecommitdiff
path: root/Master/tlpkg/TeXLive/TLWinGoo.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/TeXLive/TLWinGoo.pm')
-rw-r--r--Master/tlpkg/TeXLive/TLWinGoo.pm393
1 files changed, 234 insertions, 159 deletions
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
&register_extension
&unregister_extension
&register_file_type
&unregister_file_type
- &register_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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 08:31:44 +0000