Proposed update TLWinGoo

git-svn-id: svn://tug.org/texlive/trunk@22173 c570f23f-e606-0410-a88d-b1316a301751

3 files changed, 1423 insertions, 0 deletions

diff --git a/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm b/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm
new file mode 100644
index 00000000000..bd15e2d517f
--- /dev/null
+++ b/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm
@@ -0,0 +1,1286 @@
+# $Id: TLWinGoo.pm 19264 2010-07-07 00:06:03Z trzeciak $
+# TeXLive::TLWinGoo.pm - Windows nastiness
+# Copyright 2008, 2009, 2010, 2011 Siep Kroonenberg, Norbert Preining
+# This file is licensed under the GNU General Public License version 2
+# or any later version.
+
+# code for broadcast_env adapted from Win32::Env:
+# Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+package TeXLive::TLWinGoo;
+
+my $svnrev = '$Revision: 19264 $';
+my $_modulerevision;
+if ($svnrev =~ m/: ([0-9]+) /) {
+  $_modulerevision = $1;
+} else {
+  $_modulerevision = "unknown";
+}
+sub module_revision {
+  return $_modulerevision;
+}
+
+=pod
+
+=head1 NAME
+
+C<TeXLive::TLWinGoo> -- Additional utilities for Windows
+
+=head2 SYNOPSIS
+
+  use TeXLive::TLWinGoo;
+
+=head2 DIAGNOSTICS
+
+  TeXLive::TLWinGoo::win_version;
+  TeXLive::TLWinGoo::is_vista;
+  TeXLive::TLWinGoo::admin;
+  TeXLive::TLWinGoo::non_admin;
+  TeXLive::TLWinGoo::reg_country;
+
+=head2 ENVIRONMENT AND REGISTRY
+
+  TeXLive::TLWinGoo::expand_string($s);
+  TeXLive::TLWinGoo::global_tmpdir;
+  TeXLive::TLWinGoo::get_system_path;
+  TeXLive::TLWinGoo::get_user_path;
+  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::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, $path, $exts);
+  TeXLive::TLWinGoo::unregister_application($prog);
+  TeXLive::TLWinGoo::add_to_openwithlist($ext, $prog);
+  TeXLive::TLWinGoo::remove_from_openwithlist($ext, $prog);
+
+=head2 ACTIVATING CHANGES IMMEDIATELY
+
+  TeXLive::TLWinGoo::broadcast_env;
+  TeXLive::TLWinGoo::update_assocs;
+
+=head2 SHORTCUTS
+
+  TeXLive::TLWinGoo::desktop_path;
+  TeXLive::TLWinGoo::add_desktop_shortcut($texdir, $name, $icon,
+    $prog, $args, $batgui);
+  TeXLive::TLWinGoo::add_menu_shortcut($place, $name, $icon,
+    $prog, $args, $batgui);
+  TeXLive::TLWinGoo::remove_desktop_shortcut($name);
+  TeXLive::TLWinGoo::remove_menu_shortcut($place, $name);
+
+=head2 UNINSTALLER
+
+  TeXLive::TLWinGoo::create_uninstaller;
+  TeXLive::TLWinGoo::unregister_uninstaller;
+
+All exported functions return forward slashes.
+
+=head2 DESCRIPTION
+
+=over 4
+
+=cut
+
+BEGIN {
+  use Exporter;
+  use vars qw( @ISA @EXPORT $Registry);
+  @ISA = qw( Exporter );
+  @EXPORT = qw(
+    &win_version
+    &is_vista
+    &admin
+    &non_admin
+    &reg_country
+    &expand_string
+    &global_tmpdir
+    &get_system_path
+    &get_user_path
+    &setenv_reg
+    &unsetenv_reg
+    &adjust_reg_path_for_texlive
+    &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
+    &desktop_path
+    &add_desktop_shortcut
+    &add_menu_shortcut
+    &remove_desktop_shortcut
+    &remove_menu_shortcut
+    &create_uninstaller
+    &unregister_uninstaller
+  );
+  # for testing also:
+  @EXPORT_OK = qw(
+    &admin_again
+    &get_system_env
+    &get_user_env
+    &global_tmpdir
+    &is_a_texdir
+    &tex_dirs_on_path
+  );
+  if ($^O=~/^MSWin(32|64)$/i) {
+    require Win32::API;
+    require Win32::TieRegistry;
+    Win32::TieRegistry->import( qw( $Registry
+      REG_SZ REG_EXPAND_SZ  KEY_READ KEY_WRITE KEY_ALL_ACCESS
+         KEY_ENUMERATE_SUB_KEYS ) );
+    $Registry->Delimiter('/');
+    $Registry->ArrayValues(0);
+    $Registry->FixSzNulls(1);
+    require Win32::Shortcut;
+    Win32::Shortcut->import( qw( SW_SHOWNORMAL SW_SHOWMINNOACTIVE ) );
+  }
+}
+
+use TeXLive::TLConfig;
+use TeXLive::TLUtils;
+TeXLive::TLUtils->import( qw( mkdirhier ) );
+
+my $is_win = $^O=~/^MSWin(32|64)$/i;
+
+=pod
+
+=back
+
+=head2 DIAGNOSTICS
+
+=over 4
+
+=item C<win_version>
+
+C<win_version> returns the Windows version number as stored in the
+registry: 5.0 for Windows 2000, 5.1 for Windows XP and 6.0 for Vista.
+
+=cut
+
+my $windows_version = 0;
+
+if ($is_win) {
+  my $tempkey = $Registry->Open(
+    "LMachine/software/Microsoft/Windows NT/CurrentVersion/",
+    {Access => KEY_READ() });
+  $windows_version = $tempkey -> { "/CurrentVersion" };
+}
+
+sub win_version { return $windows_version; }
+
+=item C<is_vista>
+
+C<is_vista> returns 1 if win_version is >= 6.0, otherwise 0.
+
+=cut
+
+sub is_vista { return $windows_version >= 6; }
+
+# permissions with which we try to access the system environment
+
+my $is_admin = 1;
+
+sub sys_access_permissions {
+  $is_admin ? KEY_ALL_ACCESS() : KEY_READ() | KEY_ENUMERATE_SUB_KEYS();
+}
+
+sub get_system_env {
+  return $Registry -> Open(
+    "LMachine/system/currentcontrolset/control/session manager/Environment/",
+    {Access => sys_access_permissions()});
+}
+
+# $is_admin was set to true originally. With this value,
+# sys-access_permissions returns full access permissions. If that
+# doesn't work out then apparently we aren't administrator, so we
+# set $is_admin to 0.
+
+if ($is_win) {
+  $is_admin = 0 if not get_system_env();
+  debug("Configuring TLWinGoo for " .
+    ($is_admin ? "admin" : "user") . "mode\n") if win32();
+}
+
+sub get_user_env {
+  return $Registry -> Open("CUser/Environment", {Access => KEY_ALL_ACCESS()});
+}
+
+=pod
+
+=item C<admin>
+
+Returns admin status, admin implying having full read-write access
+to the system environment.
+
+=cut
+
+sub admin { return $is_admin; }
+
+=pod
+
+=item C<non_admin>
+
+Pretend not to have admin privileges, to enforce a user- rather than
+a system install.
+
+Currently only used for testing.
+
+=cut
+
+sub non_admin {
+  debug("TLWinGoo: switching to user mode\n");
+  $is_admin = 0;
+}
+
+# just for testing; doesn't check actual user permissions
+sub admin_again {
+  debug("TLWinGoo: switching to admin mode\n");
+  $is_admin = 1;
+}
+
+=pod
+
+=item C<reg_country>
+
+Two-letter country code representing the locale of the current user
+
+=cut
+
+sub reg_country {
+  my $value = $Registry -> {"CUser/Control Panel/International//Locale"};
+  return 0 unless $value;
+  # there might be trailing nulls on Vista
+  $value =~ s/\x00*$//;
+  $value = substr $value, -4;
+  return 0 unless $value;
+  my $lmkey = $Registry -> Open("HKEY_CLASSES_ROOT/MIME/Database/Rfc1766/",
+                             {Access => KEY_READ()});
+  return 0 unless $lmkey;
+  $lm = $lmkey->{"/$value"};
+  return 0 unless $lm;
+  debug("found lang codes value = $value, lm = $lm...\n");
+  if ($lm) {
+    if ($lm =~ m/^zh-(tw|hk)$/i) {
+      return ("zh-tw");
+    } elsif ($lm =~ m/^zh/) {
+      # for anything else starting with zh return, that is zh, zh-cn, zh-sg
+      # and maybe something else
+      return ("zh-cn");
+    } else {
+      return(substr $lm, 0, 2);
+    }
+  }
+}
+
+=pod
+
+=back
+
+=head2 ENVIRONMENT AND REGISTRY
+
+Most settings can be made for a user and for the system. User
+settings override system settings.
+
+For admin users, the functions below affect both user- and system
+settings. For non-admin users, only user settings are changed.
+
+An exception is the search path: the effective searchpath consists
+of the system searchpath in front concatenated with the user
+searchpath at the back.
+
+Note that in a roaming profile network setup, users take only user
+settings with them to other systems, not system settings. In this
+case, with a TeXLive on the network, a nonadmin install makes the
+most sense.
+
+=over 4
+
+=item C<expand_string($s)>
+
+This function replaces substrings C<%env_var%> with their current
+values as environment variable and returns the result.
+
+=cut
+
+sub expand_string {
+  my ($s) = @_;
+  $s =~ s/%([^%;]+)%/$ENV{$1} ? $ENV{$1} : "%$1%"/eg;
+  return $s;
+}
+
+=pod
+
+=item C<global_tmpdir>
+
+Returns the expanded value of C<%TEMP%> from the system environment,
+usually C<%SystemRoot%/Temp>. This value is normally not available
+from C<%ENV>.
+
+=cut
+
+if ($is_win) {
+  $global_tmp = expand_string(get_system_env()->{'TEMP'}) if $is_win;
+}
+
+my $global_tmp = "/tmp";
+
+sub global_tmpdir { return $global_tmp; }
+
+sub is_a_texdir {
+  my $d = shift;
+  $d =~ s/\\/\//g;
+  $d = $d . '/' unless $d =~ m!/$!;
+  # don't consider anything under %systemroot% a texdir
+  my $sr = uc($ENV{'SystemRoot'});
+  $sr =~ s/\\/\//g;
+  $sr = $sr . '/' unless $sr =~ m!/$!;
+  return 0 if index($d, $sr)==0;
+  foreach $p qw(luatex.exe mktexlsr.exe pdftex.exe tex.exe xetex.exe) {
+    return 1 if (-e $d.$p);
+  }
+  return 0;
+}
+
+=pod
+
+=item C<get_system_path>
+
+Returns unexpanded system path, as stored in the registry, but with
+forward slashes.
+
+=cut
+
+sub get_system_path {
+  my $value = get_system_env() -> {'/Path'};
+  # Remove terminating zero bytes; there may be several, at least
+  # under w2k, and the FixSzNulls option only removes one.
+  $value =~ s/[\s\x00]+$//;
+  return $value;
+}
+
+=pod
+
+=item C<get_user_path>
+
+Returns unexpanded user path, as stored in the registry, but with
+forward slashes. The user path often does not exist, and is rarely
+expandable.
+
+=cut
+
+sub get_user_path {
+  my $value = get_user_env() -> {'/Path'};
+  return "" if not $value;
+  $value =~ s/[\s\x00]+$//;
+  return $value;
+}
+
+#=pod
+#
+#=item C<win_which_dir>
+#
+#More or less the same as which, except that 1. it returns a
+#directory, 2. it consults the path stored in the registry rather
+#than the path of the current process, and 3. it assumes that the
+#filename includes an extension. Currently only used for testing.
+#
+#=cut
+#
+#sub win_which_dir {
+#  my $prog = shift;
+#  my $d;
+#  # first check system path
+#  my $path = expand_string(get_system_path());
+#  my $user_path = expand_string(get_user_path());
+#  $path = $path . ';' . $user_path if $user_path;
+#  $path =~ s/\\/\//g;
+#  foreach $d (split (';',$path)) {
+#    $d =~ s/\/$//;
+#    return $d if -e $d.'/'.$prog;
+#  }
+#  return 0;
+#}
+
+=pod
+
+=item C<setenv_reg($env_var, $env_data[, $mode]);>
+
+Set an environment variable $env_var to $env_data.
+
+$mode="user": set for current user. $mode="system": set for all
+users. Default: both if admin, current user otherwise.
+
+=cut
+
+sub setenv_reg {
+  my $env_var = shift;
+  my $env_data = shift;
+  my $mode = @_ ? shift : "default";
+  die "setenv_reg: Invalid mode $mode"
+    if ($mode ne "user" and $mode ne "system" and $mode ne "default");
+  die "setenv_reg: mode 'system' only available for admin"
+    if ($mode eq "system" and !$is_admin);
+  my $env;
+  if ($mode ne "system") {
+    $env = get_user_env();
+    $env->ArrayValues(1);
+    $env->{'/'.$env_var} =
+       [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
+  }
+  if ($mode ne "user" and $is_admin) {
+    $env = get_system_env();
+    $env->ArrayValues(1);
+    $env->{'/'.$env_var} =
+       [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
+  }
+}
+
+=pod
+
+=item C<unsetenv_reg($env_var[, $mode]);>
+
+Unset an environment variable $env_var
+
+=cut
+
+sub unsetenv_reg {
+  my $env_var = shift;
+  my $env = get_user_env();
+  my $mode = @_ ? shift : "default";
+  #print "Unsetenv_reg: unset $env_var with mode $mode\n";
+  die "unsetenv_reg: Invalid mode $mode"
+    if ($mode ne "user" and $mode ne "system" and $mode ne "default");
+  die "unsetenv_reg: mode 'system' only available for admin"
+    if ($mode eq "system" and !$is_admin);
+  delete get_user_env()->{'/'.$env_var} if $mode ne "system";
+  delete get_system_env()->{'/'.$env_var} if ($mode ne "user" and $is_admin);
+}
+
+=pod
+
+=item C<tex_dirs_on_path($path)>
+
+Returns tex directories found on the search path.
+A directory is a TeX directory if it contains tex.exe or
+pdftex.exe.
+
+=cut
+
+sub tex_dirs_on_path {
+  my ($path) = @_;
+  my ($d, $d_exp);
+  my @texdirs = ();
+  foreach $d (split (';', $path)) {
+    $d_exp = expand_string($d);
+    if (is_a_texdir($d_exp)) {
+      # tlwarn("Possibly conflicting [pdf]TeX program found at $d_exp\n");
+      push(@texdirs, $d_exp);
+    };
+  }
+  return @texdirs;
+}
+
+=pod
+
+=item C<adjust_reg_path_for_texlive($action, $tlbindir, $mode)>
+
+Edit system or user PATH variable in the registry.
+Adds or removes (depending on $action) $tlbindir directory
+to system or user PATH variable in the registry (depending on $mode).
+
+=cut
+
+sub adjust_reg_path_for_texlive {
+  my ($action, $tlbindir, $mode) = @_;
+  die("Unknown path action: $action\n")
+    if ($action ne 'add') && ($action ne 'remove');
+  die("Unknown path mode: $mode\n")
+    if ($mode ne 'system') && ($mode ne 'user');
+  debug("Warning: [pdf]tex program not found in $tlbindir\n")
+    if (!is_a_texdir($tlbindir));
+  my $path = ($mode eq 'system') ? get_system_path() : get_user_path();
+  $tlbindir =~ s!/!\\!g;
+  my $tlbindir_short = uc(short_name($tlbindir));
+  my ($d, $d_short, @newpath);
+  my $tex_dir_conflict = 0;
+  my @texdirs;
+  foreach $d (split (';', $path)) {
+    $d_short = uc(short_name(expand_string($d)));
+    $d_short =~ s!/!\\!g;
+    ddebug("adjust_reg: compar $d_short with $tlbindir_short\n");
+    if ($d_short ne $tlbindir_short) {
+      push(@newpath, $d);
+      if (is_a_texdir($d)) {
+        $tex_dir_conflict++;
+        push(@texdirs, $d);
+      }
+    }
+  }
+  if ($action eq 'add') {
+    if ($tex_dir_conflict) {
+      log("Warning: conflicting [pdf]tex program found on the $mode path ", 
+          "in @texdirs; appending $tlbindir to the front of the path.\n");
+      unshift(@newpath, $tlbindir);
+    } else {
+      push(@newpath, $tlbindir);
+    }
+  }
+  if (@newpath) {
+    debug("TLWinGoo: adjust_reg_path_for_texlive: calling setenv_reg in $mode\n");
+    setenv_reg("Path", join(';', @newpath), $mode);
+  } else {
+    debug("TLWinGoo: adjust_reg_path_for_texlive: calling unsetenv_reg in $mode\n");
+    unsetenv_reg("Path", $mode);
+  }
+  if ( ($action eq 'add') && ($mode eq 'user') ) {
+    @texdirs = tex_dirs_on_path( get_system_path() );
+    return 0 unless (@texdirs);
+    tlwarn("Warning: conflicting [pdf]tex program found on the system path ",
+           "in @texdirs; not fixable in user mode.\n");
+    return 1;
+  }
+  return 0;
+}
+
+### helper subs for file types ###
+
+# delete a registry key recursively.
+# the key parameter should be a string, not a registry object.
+
+sub getans {
+  my $prompt = shift;
+  my $ans;
+  print STDERR "$prompt\n";
+  $ans = <STDIN>;
+  if ($ans =~ /^y/i) {return 1;}
+  die "Aborting as requested";
+}
+
+sub reg_delete_recurse {
+  my $parent = shift;
+  my $childname = shift;
+  my $parentpath = $parent->Path;
+  ddebug("Deleting $parentpath$childname\n");
+  my $child;
+  if ($childname !~ '^/') { # subkey
+    $child = $parent->Open ($childname, {Access => KEY_ALL_ACCESS()});
+    return unless $child;
+    foreach my $v (keys %$child) {
+      if ($v =~ '^/') { # value
+        delete $child->{$v};
+      } else { # subkey
+        reg_delete_recurse ($child, $v);
+      }
+    }
+    delete $child->{'/'};
+  }
+  delete $parent->{$childname};
+}
+
+sub cu_root {
+  my $k = $Registry -> Open("CUser", {
+    Access => KEY_ALL_ACCESS(), Delimiter => '/'
+  });
+  die "Cannot open HKCU for writing" unless $k;
+  return $k;
+}
+
+sub lm_root {
+  my $k = $Registry -> Open("LMachine", {
+      Access => ($is_admin ? KEY_ALL_ACCESS() : KEY_READ()),
+      Delimiter => '/'
+  });
+  die "Cannot open HKLM for ".($is_admin ? "writing" : "reading")
+      unless $k;
+  return $k;
+}
+
+# write a registry key or not, depending on
+# mode, existing keys and privilege level
+
+sub do_write_regkey {
+  my $mode = shift;
+  my $keypath = shift; # modulo cu/lm
+  my $keyhash = shift; # ref to a possibly nested hash
+  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
+  my ($parentpath, $keyname);
+  if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) {
+    ($parentpath, $keyname) = ($1, $2);
+    $keyname .= '/';
+    debug "key - $hivename - $parentpath - $keyname\n";
+  } else {
+    die "Cannot determine final component of $keypath";
+  }
+
+  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;
+  if ($is_admin) {
+    $parentkey = $lm_key->Open($parentpath);
+    if (!$parentkey) {
+      # in most cases, this probably shouldn't happen for lm
+      $parentkey = $lm_key->CreateKey($parentpath);
+    }
+  } else {
+    $parentkey = $cu_key->Open($parentpath);
+    if (!$parentkey) {
+      $parentkey = $cu_key->CreateKey($parentpath);
+    }
+  }
+  if (!$parentkey) {
+    tlwarn "Cannot create parent of $hivename/$keypath\n";
+    return 0;
+  }
+  if ($parentkey->{$keyname}) {reg_delete_recurse($parentkey, $keyname);}
+  $parentkey->{$keyname} = $keyhash;
+  if (!$parentkey->{$keyname}) {
+    tlwarn "Failure to create HKLM/$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;
+  }
+  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 $hivename = $is_admin ? 'HKLM' : 'HKCU';
+
+  if ($mode == 0) {
+    ddebug "Mode 0: not removing $hivename/$keypath key\n";
+    return 1;
+  }
+
+  my ($parentpath, $keyname);
+  if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) {
+    ($parentpath, $keyname) = ($1, $2);
+    $keyname .= '/';
+  } else {
+    die "Cannot determine final component of $keypath";
+  }
+
+  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);
+  } else {
+    $parentkey = $cu_key->Open($parentpath);
+  }
+  if (!$parentkey) {
+    $do_remove = 0;
+    tlwarn "Unable to open $roothive/$parentpath for writing\n";
+    return 0;
+  }
+  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";
+    }
+  };
+  return 1 unless $do_remove;
+  #getans("Deleting $parentpath$keyname regkey? ");
+  reg_delete_recurse($parentkey, $keyname);
+  if ($parentkey->{$keyname}) {
+    tlwarn "Failure to delete $roothive/$keypath\n";
+    return 0;
+  }
+  if ($is_admin and $cu_key->{$parentpath}) {
+    reg_delete_recurse($cu_key->{$parentpath}, $keyname);
+    # no errorchecking this once
+  }
+  return 1;
+}
+
+=pod
+
+=item C<register_extension($mode, $extension, $file_type)>
+
+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.
+
+=cut
+
+sub register_extension {
+  my $mode = shift;
+  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);
+}
+
+=pod
+
+=item C<unregister_extension($mode, $extension, $filetype)>
+
+Reversal of register_extension.
+
+=cut
+
+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.
+  my $extension = shift;
+  my $filetype = shift;
+  $extension = '.'.$extension unless $extension =~ /^\./;
+  debug("unregistering $extension\n");
+
+  $testhash = {"/" => $filetype};
+  do_remove_regkey($mode, "Software/Classes/".$extension, $testhash);
+}
+
+=pod
+
+=item C<register_file_type($file_type, $command)>
+
+Add registry entries to associate $file_type with $command. Slashes
+are flipped where necessary. Double quotes should be added by the
+caller if necessary.
+
+=cut
+
+sub register_file_type {
+  my $file_type = shift;
+  my $command = shift;
+  $command =~s/\//\\/g;
+  debug ("Linking $file_type to $command\n");
+  my $keyhash = {
+    "shell/" => {
+      "open/" => {
+        "command/" => {
+          "/" => $command
+        }
+      }
+    }
+  };
+  do_write_regkey(2, "Software/Classes/$file_type", $keyhash);
+}
+
+=pod
+
+=item C<unregister_file_type($file_type)>
+
+Reversal of register_script_type.
+
+=cut
+
+sub unregister_file_type {
+  # we don't error check; we just do the best we can.
+  my $file_type = shift;
+  debug ("unregistering $file_type\n");
+  do_remove_regkey(2, "Software/Classes/$file_type/");
+}
+
+=pod
+
+=item C<register_application($prog, $path, $exts)>
+
+Add registry entry to set full path of $prog to $path and optionally
+specify which extensions it handles
+
+=cut
+
+sub register_application {
+  my $prog = shift; # redundant, but more natural than just $path
+  my $path = shift;
+  my $exts = shift;
+
+  my $hsh;
+  foreach my $e (@$exts) {$hsh->{"/$e"} = "";}
+  #my $prog = TeXLive::TLUtils::basename($path);
+  $cmd = "\"$path\" \"%1\"";
+  $cmd =~ s!/!\\!g;
+  my $keyhash = {
+    "shell/" => {
+      "open/" => {
+        "command/" => {
+          "/" => $cmd
+        }
+      }
+    },
+    "SupportedTypes" => $hsh
+  };
+  do_write_regkey(2, "Software/Classes/Applications/$prog", $keyhash);
+}
+
+=pod
+
+=item C<unregister_application($prog)>
+
+Reversal of register_application
+
+=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");
+}
+
+=pod
+
+=back
+
+=head2 ACTIVATING CHANGES IMMEDIATELY
+
+=over 4
+
+=item C<broadcast_env>
+
+Broadcasts system message that enviroment has changed. This only has
+an effect on newly-started programs, not on running programs and the
+processes they spawn.
+
+=cut
+
+sub broadcast_env() {
+  use constant HWND_BROADCAST	=> 0xffff;
+  use constant WM_SETTINGCHANGE	=> 0x001A;
+  my $result = "";
+  my $SendMessage;
+  debug("Broadcasting \"Enviroment settings changed\" message...\n");
+  #$SendMessage = new Win32::API('user32', 'SendMessage', 'LLPP', 'L');
+  #$result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE,
+  #    0, 'Environment') if $SendMessage;
+  $SendMessage = new Win32::API('user32', 'SendMessageTimeout', 'LLPPLLP', 'L');
+  my $ans = "12345678"; # room for dword
+  $result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE,
+      0, 'Environment', 0, 2000, $ans) if $SendMessage;
+  debug("Broadcast complete; result: $result.\n");
+}
+
+=pod
+
+=item C<update_assocs>
+
+Notifies the system that filetypes have changed.
+
+=cut
+
+sub update_assocs() {
+  use constant SHCNE_ASSOCCHANGED	=> 0x8000000;
+  use constant SHCNF_IDLIST =>	0;
+  my $update_fu = new Win32::API('shell32', 'SHChangeNotify', 'LIPP', 'V');
+  if ($update_fu) {
+    debug("Notifying changes in filetypes...\n");
+    $update_fu->Call (SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0);
+    debug("Done notifying\n");
+  } else {
+    debug("No update_fu\n");
+  }
+}
+
+=pod
+
+=back
+
+=head2 SHORTCUTS
+
+=cut
+
+# short path names
+
+my $shortfu;
+if ($^O=~/^MSWin(32|64)$/i) {
+  $shortfu = new Win32::API('kernel32', 'GetShortPathName', 'PPN', 'N');
+}
+
+sub short_name {
+  my ($fname) = @_;
+  return $fname unless $is_win;
+  my $buffer = (' ' x 260);
+  my $slength = $shortfu->Call($fname, $buffer, 260);
+  if ($slength>0) { return substr $buffer, 0, $slength; }
+  else { return ''; }
+}
+
+=pod
+
+=over 4
+
+=item C<shell_folder>
+
+Location of shell `special folders'; $user_name is the name
+to look for in user mode, $admin_name is the name for admin mode,
+e.g. `Desktop' and `Common Desktop'. The default for $admin_name is
+'Common .$user_name
+
+=cut
+
+sub shell_folder {
+  my ($user_name, $admin_name) = @_;
+  $admin_name = 'Common '.$user_name unless ($admin_name or !$user_name);
+  my ($shell_key, $sh_folder);
+  if (admin()) {
+    return 0 unless $admin_name;
+    $shell_key = $Registry->Open(
+    "LMachine/software/microsoft/windows/currentversion/explorer/user shell folders/",
+      {Access => KEY_READ}) or return 0;
+    $sh_folder = $shell_key -> {"/$admin_name"};
+    $sh_folder = short_name(expand_string($sh_folder));
+  } else {
+    $shell_key = $Registry->Open(
+    "CUser/software/microsoft/windows/currentversion/explorer/user shell folders/",
+      {Access => KEY_READ}) or return 0;
+    $sh_folder = $shell_key -> {"/$user_name"};
+    $sh_folder = short_name(expand_string($sh_folder));
+  }
+  $sh_folder =~ s!\\!/!g;
+  return $sh_folder;
+}
+
+sub desktop_path() {
+  return shell_folder('Desktop');
+}
+
+sub menu_path() {
+  return shell_folder('Programs', 'Common Programs');
+}
+
+=pod
+
+=item C<add_desktop_shortcut($name, $icon, $prog, $args, $batgui)>
+
+Add a desktop shortcut, with name $name and icon $icon, pointing to
+program $prog with parameters $args (a string).  Use a non-null
+batgui parameter if the shortcut starts a gui program via a
+batchfile. Then the inevitable command prompt will be hidden
+rightaway, leaving only the gui program visible.
+
+=cut
+
+sub add_desktop_shortcut {
+  my ($name, $icon, $prog, $args, $batgui) = @_;
+
+  # create shortcut
+  my ($shc, $shpath, $shfile);
+  $shc = new Win32::Shortcut();
+  $shc->{'IconLocation'} = $icon if -f $icon;
+  $shc->{'Path'} = $prog;
+  $shc->{'Arguments'} = $args;
+  $shc->{'ShowCmd'} = $batgui ? SW_SHOWMINNOACTIVE : SW_SHOWNORMAL;
+  $shfile = desktop_path().'/'.$name.'.lnk';
+  $shc->Save($shfile);
+}
+
+=pod
+
+=item C<add_menu_shortcut($place, $name, $icon,
+  $prog, $args, $batgui)>
+
+Add a menu shortcut at place $place (relative to Start/Programs),
+with name $name and icon $icon, pointing to program $prog with
+parameters $args. See above for batgui.
+
+=cut
+
+sub add_menu_shortcut {
+  my ($place, $name, $icon, $prog, $args, $batgui) = @_;
+  $place =~ s!\\!/!g;
+
+  my ($shc, $shpath, $shfile);
+  $shc = new Win32::Shortcut();
+  $shc->{'IconLocation'} = $icon if -f $icon;
+  $shc->{'Path'} = $prog;
+  $shc->{'Arguments'} = $args;
+  $shc->{'ShowCmd'} = $batgui ? SW_SHOWMINNOACTIVE : SW_SHOWNORMAL;
+  $shpath = $place;
+  $shpath =~ s!\\!/!g;
+  $shpath = '/'.$shpath unless $shpath =~ m!^/!;
+  $shpath = menu_path().$shpath;
+  if ((-e $shpath) and not (-d $shpath)) {
+    next; # fail silently and don't worry about it
+  } elsif (not (-d $shpath)) {
+    mkdirhier($shpath);
+    return unless -d $shpath;
+  }
+  $shfile = $shpath.'/'.$name.'.lnk';
+  $shc->Save($shfile);
+}
+
+=pod
+
+=item C<remove_desktop_shortcut($name)>
+
+For uninstallation of an individual package.
+
+=cut
+
+sub remove_desktop_shortcut {
+  my $name = shift;
+  unlink desktop_path().'/'.$name.'.lnk';
+}
+
+=pod
+
+=item C<remove_menu_shortcut($place, $name)>
+
+For uninstallation of an individual package.
+
+=cut
+
+sub remove_menu_shortcut {
+  my $place = shift;
+  my $name = shift;
+  $place =~ s!\\!/!g;
+  $place = '/'.$place unless $place =~ m!^/!;
+  unlink menu_path().$place.'/'.$name.'.lnk';
+}
+
+=pod
+
+=back
+
+=head2 UNINSTALLER
+
+=over 4
+
+=item C<create_uninstaller>
+
+Writes registry entries for add/remove programs which  reference
+the uninstaller script and creates uninstaller batchfiles to finish
+the job.
+
+=cut
+
+sub create_uninstaller {
+  my ($tdfw, $tdwfw, $tdsvfw, $tdscfw) = @_;
+  # TEXDIR, TEXDIRW, TEXMFSYSVAR, TEXMFSYSCONFIG
+  $tdfw =~ s![\\/]$!!;
+  my $td = $tdfw;
+  $td =~ s!/!\\!g;
+
+  $tdwfw =~ s![\\/]$!!;
+  my $tdw = $tdwfw;
+  $tdw =~ s!/!\\!g;
+
+  $tdsvfw =~ s![\\/]$!!;
+  my $tdsv = $tdsvfw;
+  $tdsv =~ s!/!\\!g;
+
+  $tdscfw =~ s![\\/]$!!;
+  my $tdsc = $tdscfw;
+  $tdsc =~ s!/!\\!g;
+
+  my $uninst_key = $Registry -> Open((admin() ? "LMachine" : "CUser") .
+    "/software/microsoft/windows/currentversion/",
+    {Access => KEY_ALL_ACCESS()});
+  my $k = $uninst_key->CreateKey(
+    "uninstall/TeXLive$::TeXLive::TLConfig::ReleaseYear/");
+  $k->{"/DisplayName"} = "TeX Live $::TeXLive::TLConfig::ReleaseYear";
+  $k->{"/UninstallString"} = "\"$tdw\\tlpkg\\installer\\uninst.bat\"";
+  $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear;
+  $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive";
+
+  mkdirhier("$tdwfw/tlpkg/installer"); # wasn't this done yet?
+  if (open UNINST, ">$tdwfw/tlpkg/installer/uninst.bat") {
+    print UNINST <<UNEND;
+\@echo off
+setlocal
+rem This should not be necessary, but sometimes it is:
+path $td\\tlpkg\\tlperl\\bin;$td\\bin\\win32;%path%
+set PERL5LIB=$td\\tlpkg\\tlperl\\lib
+perl.exe \"$td\\texmf\\scripts\\texlive\\uninstall-win32.pl\"
+if errorlevel 1 goto :eof
+copy \"$tdw\\tlpkg\\installer\\uninst2.bat\" \"\%TEMP\%\"
+rem pause
+\"\%TEMP\%\\uninst2.bat\"
+UNEND
+;
+  close UNINST;
+  } else {
+    warn "Cannot open $tdwfw/tlpkg/installer/uninst.bat for append";
+  }
+
+  if (open UNINST2, ">$tdwfw/tlpkg/installer/uninst2.bat") {
+    print UNINST2 <<UNEND2 if ($td eq $tdw);
+rmdir /s /q \"$td\\texmf-dist\"
+rmdir /s /q \"$td\\texmf-doc\"
+rmdir /s /q \"$td\\texmf\"
+rmdir /s /q \"$td\\readme-html.dir\"
+rmdir /s /q \"$td\\readme-txt.dir\"
+rmdir /s /q \"$td\\bin\"
+rmdir /s /q \"$td\\tlpkg\"
+del /q \"$td\\README.*\"
+del /q \"$td\\LICENSE.*\"
+del /q \"$td\\doc.html\"
+del \"$td\\index.html\"
+del \"$td\\texmf.cnf\"
+del \"$td\\install-tl\"
+del \"$td\\tl-portable\"
+del \"$td\\tl-portable.bat\"
+del \"$td\\install-tl.bat\"
+del \"$td\\install-tl-advanced.bat\"
+UNEND2
+;
+    print UNINST2 <<UNEND2;
+rmdir /s /q \"$tdsv\"
+rmdir /s /q \"$tdsc\"
+rmdir /s /q \"$tdw\\temp\"
+rmdir /s /q \"$tdw\\tlpkg\"
+del \"$tdw\\install-tl.log\"
+del \"$tdw\\texlive.profile\" 2>nul
+del \"$tdw\\release-texlive.txt\"
+set test=
+for \%\%f in (\"$tdw\\*.*\") do \@set test=nonempty
+if x\%test\%==x rd \"$tdw\"
+\@echo Done uninstalling TeXLive.
+rem \@pause
+del %0
+UNEND2
+;
+    close UNINST2;
+  } else {
+    warn "Cannot open $tdwfw/tlpkg/installer/uninst2.bat for writing";
+  }
+}
+
+=pod
+
+=item C<unregister_uninstaller>
+
+Removes TeXLive from Add/Remove Programs.
+
+=cut
+
+sub unregister_uninstaller {
+  my ($w32_multi_user) = @_;
+  my $regkey_uninst_path = ($w32_multi_user ? "LMachine" : "CUser") . 
+    "/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/") 
+    if $regkey_uninst;
+}
+
+=pod
+
+=back
+
+=cut
+
+# needs a terminal 1 for require to succeed!
+1;
+
+### Local Variables:
+### perl-indent-level: 2
+### tab-width: 2
+### indent-tabs-mode: nil
+### End:
+# vim:set tabstop=2 expandtab: #
diff --git a/Master/tlpkg/dev/tlwingoonew/testw32 b/Master/tlpkg/dev/tlwingoonew/testw32
new file mode 100644
index 00000000000..63ed256a11c
--- /dev/null
+++ b/Master/tlpkg/dev/tlwingoonew/testw32
@@ -0,0 +1,132 @@
+#!/usr/bin/env perl
+BEGIN {
+  $^W = 1;
+  my $Master;
+  my $me = $0;
+  $me =~ s!\\!/!g if $^O =~ /^MSWin(32|64)$/i;
+  if ($me =~ m!/!) {
+    ($Master = $me) =~ s!(.*)/[^/]*$!$1!;
+  } else {
+    $Master = ".";
+  }
+  $::installerdir = $Master;
+  unshift (@INC, "$::installerdir/tlpkg");
+}
+
+$::opt_verbosity=2;
+
+use TeXLive::TLWinGoo;
+Win32::TieRegistry->import( qw( $Registry
+));
+#  REG_SZ REG_EXPAND_SZ  KEY_READ KEY_WRITE KEY_ALL_ACCESS
+#     KEY_ENUMERATE_SUB_KEYS
+$Registry->Delimiter('/');
+$Registry->ArrayValues(0);
+
+sub print_reg {
+  my $k = shift;
+  $kb = $k;
+  $kb =~ s!/!\\!g;
+  if (defined($Registry->{"LMachine/$k/"})) {
+    print "\nHKLM/$k/:\n";
+    print `reg query HKLM\\$kb /s`;
+  } else {
+    print "\nHKLM/$k/: no such entry\n";
+  }
+  #print $out;
+  if (defined($Registry->{"CUser/$k/"})) {
+    print "\nHKCU/$k/:\n";
+    print `reg query HKCU\\$kb /s`;
+  } else {
+    print "\nHKCU/$k/: no such entry\n";
+  }
+  #print $out;
+}
+
+$regpath = "Software/Classes/test";
+$testkey = {
+ '/' => "default_value",
+ '/a' => "another value"
+};
+
+TeXLive::TLWinGoo::do_write_regkey(2, $regpath, $testkey);
+print_reg($regpath);
+
+# extensions
+
+$regpath = 'Software/Classes/';
+$ext = '.tex';
+
+register_extension(0, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+register_extension(1, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+register_extension(2, $ext, 'TL.TeXworks.edit');
+print_reg("$regpath$ext");
+
+register_extension(1, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+unregister_extension(0, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+unregister_extension(1, $ext, 'TL.TeXworks.edit');
+print_reg("$regpath$ext");
+
+unregister_extension(1, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+register_extension(1, $ext, 'texfile');
+print_reg("$regpath$ext");
+
+unregister_extension(2, $ext, 'TL.TeXworks.edit');
+print_reg("$regpath$ext");
+
+# file types
+
+$filetype = 'TL.TeXworks.edit';
+
+register_file_type('TL.TeXworks.edit', "\"$::installerdir/bin/win32/texworks.exe\" \"%1\"");
+print_reg("$regpath$filetype");
+
+unregister_file_type('TL.TeXworks.edit');
+print_reg("$regpath$filetype");
+
+# applications
+
+$regpath = "Software/Classes/Applications/";
+$prog = "texworks.exe";
+$path = "$::installerdir/bin/win32/texworks.exe";
+$exts = ['.tex','.sty','.cls','.ltx'];
+
+register_application($prog, $path, $exts);
+print_reg("$regpath$prog");
+
+unregister_application($prog);
+print_reg("$regpath$prog");
+
+$prog = "bitmap2eps.exe";
+$path = "$::installerdir/bin/win32/bitmap2eps.exe";
+$exts = ['.png','.jpg','.gif','.bmp'];
+
+register_application($prog, $path, $exts);
+print_reg("$regpath$prog");
+
+unregister_application($prog);
+print_reg("$regpath$prog");
+
+# openwithlist
+
+$regpath = "Software/Classes/";
+$ext = ".gif";
+$prog = "bitmap2eps.exe";
+
+add_to_openwithlist($ext, $prog);
+print_reg("$regpath$ext");
+
+remove_from_openwithlist($ext, $prog);
+print_reg("$regpath$ext");
+
+update_assocs();
diff --git a/Master/tlpkg/dev/tlwingoonew/testw32.bat b/Master/tlpkg/dev/tlwingoonew/testw32.bat
new file mode 100755
index 00000000000..c8388718456
--- /dev/null
+++ b/Master/tlpkg/dev/tlwingoonew/testw32.bat
@@ -0,0 +1,5 @@
+@echo off
+setlocal enableextensions
+set path=%~dp0bin\win32;%path%
+set PERL5LIB=%~dp0tlpkg\tlperl\lib
+%~dp0tlpkg\tlperl\bin\perl.exe %~dpn0