TLWinGoo: better support for an uninstaller.

Added function update_assocs to notify the system of changed file
associations.
Updates to wingoo-demo


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

4 files changed, 514 insertions, 162 deletions

diff --git a/Master/install-tl.pl b/Master/install-tl.pl
index 03346decdf6..1a149c1e8d6 100755
--- a/Master/install-tl.pl
+++ b/Master/install-tl.pl
@@ -7,7 +7,7 @@
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
 #
-# TODO: 
+# TODO:
 #  - support option_paper (paper instead of A4)
 #    missing
 
@@ -763,7 +763,7 @@ sub do_postinst_stuff {
   my $perl_libdir="$TEXDIR/tlpkg/tlperl/lib";
 
   tllog($::LOG_NORMAL, "Prepending $plat_bindir to PATH\n");
-  
+
   $ENV{'PATH'}="$plat_bindir" . "$pathsep" . "$ENV{'PATH'}";
 
   if (win32) {
@@ -789,16 +789,16 @@ sub do_postinst_stuff {
   system('mktexlsr', "$TEXDIR/texmf-dist", "$TEXDIR/texmf");
 
   # we have to generate the various config file. That could be done with
-  # texconfig generate * but Win32 does not have texconfig. But we have 
+  # texconfig generate * but Win32 does not have texconfig. But we have
   # $localtlpdb and this is simple code, so do it directly, i.e., duplicate
   # the code from the various generate-*.pl scripts
   tllog($::LOG_NORMAL, "writing fmtutil.cnf data to $TEXMFSYSVAR/web2c/fmtutil.cnf\n");
-  TeXLive::TLUtils::create_fmtutil($localtlpdb, 
+  TeXLive::TLUtils::create_fmtutil($localtlpdb,
     "$TEXMFSYSVAR/web2c/fmtutil.cnf",
     "$TEXMFLOCAL/web2c/fmtutil-local.cnf");
 
   tllog($::LOG_NORMAL, "writing updmap.cfg to $TEXMFSYSVAR/web2c/updmap.cfg\n");
-  TeXLive::TLUtils::create_updmap ($localtlpdb, 
+  TeXLive::TLUtils::create_updmap ($localtlpdb,
     "$TEXMFSYSVAR/web2c/updmap.cfg",
     "$TEXMFLOCAL/web2c/updmap-local.cfg");
 
@@ -809,7 +809,7 @@ sub do_postinst_stuff {
 
   tllog($::LOG_NORMAL, "running updmap-sys\n");
   system('updmap-sys', '--nohash');
-  
+
   tllog($::LOG_NORMAL, "re-running mktexlsr $TEXMFSYSVAR\n");
   system('mktexlsr', "$TEXMFSYSVAR");
 
@@ -920,7 +920,7 @@ sub do_texmf_cnf {
       push @newtmf, $line;
     }
   }
-  open(TMF,">$vars{'TEXDIR'}/texmf/web2c/texmf.cnf") 
+  open(TMF,">$vars{'TEXDIR'}/texmf/web2c/texmf.cnf")
       or die("Can't open $vars{'TEXDIR'}/texmf/web2c/texmf.cnf for writing: $!\n");
   foreach (@newtmf) { print TMF; }
   close(TMF);
@@ -933,7 +933,8 @@ sub do_win_registry_magic {
   #$winpath =~ s!/!\\!g;
   add_texbindir_to_path($winpath);
   register_script_type(".texlua", $winpath."/texlua.exe");
-  broadcast_env;
+  broadcast_env();
+  update_assocs();
 }
 
 #
diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm
index 4e1da8d25d5..8a083cd7b6e 100644
--- a/Master/tlpkg/TeXLive/TLWinGoo.pm
+++ b/Master/tlpkg/TeXLive/TLWinGoo.pm
@@ -24,6 +24,7 @@ C<TeXLive::TLWinGoo> -- Additional utilities for Windows
 
   TeXLive::TLWinGoo::wg_error;
   TeXLive::TLWinGoo::admin;
+  TeXLive::TLWinGoo::non_admin;
   TeXLive::TLWinGoo::reg_country;
   TeXLive::TLWinGoo::dir_writable($d);
   TeXLive::TLWinGoo::expand_string($s);
@@ -34,6 +35,7 @@ C<TeXLive::TLWinGoo> -- Additional utilities for Windows
   TeXLive::TLWinGoo::register_script_type($extension, $command);
   TeXLive::TLWinGoo::unregister_script_type($extension);
   TeXLive::TLWinGoo::broadcast_env;
+  TeXLive::TLWinGoo::update_assocs;
 
 All exported functions return forward slashes.
 
@@ -50,6 +52,7 @@ BEGIN {
   @EXPORT = qw(
     &wg_error
     &admin
+    &non_admin
     &reg_country
     &dir_writable
     &expand_string
@@ -57,11 +60,20 @@ BEGIN {
     &get_system_path
     &get_user_path
     &add_texbindir_to_path
+    &remove_texbindir_from_path
     &register_script_type
     &unregister_script_type
     &broadcast_env
+    &update_assocs
+  );
+  # for testing also:
+  @EXPORT_OK = qw(
+    &admin_again
+    &get_system_env
+    &get_user_env
+    &win_which_dir
+    &global_tmpdir
   );
-
   if ($^O=~/^MSWin(32|64)$/i) {
     require Win32::API;
     require Win32::TieRegistry;
@@ -124,7 +136,7 @@ sub get_user_env {
 =item C<wg_error>
 
 Returns WinGoo error status, in the shape of an array (number,
-message) and clears the error status. No error <=> error numer 0
+message) and clears the error status. No error <=> error number 0
 
 =cut
 
@@ -139,11 +151,8 @@ sub wg_error {
 
 =item C<admin>
 
-Our test for being an administrator is the ability to change the
-system environment.
-
-It would be nice to have an install/menu option to set admin to
-false in case the user wants to install just for himself.
+Returns admin status, admin implying having full read-write access
+to the system environment.
 
 =cut
 
@@ -151,6 +160,22 @@ sub admin { return $is_admin; }
 
 =pod
 
+=item C<non_admin>
+
+Renounce admin privileges, to enforce a user- rather than a system
+install.
+
+Currently only used for testing.
+
+=cut
+
+sub non_admin { $is_admin = 0; }
+
+# just for testing; doesn't check actual user permissions
+sub admin_again { $is_admin = 1; }
+
+=pod
+
 =item C<reg_country>
 
 Two-letter country code representing the locale of the current user
@@ -191,6 +216,9 @@ sub dir_writable {
   my $written = 0;
   $written = (print TEST "\n");
   close TEST;
+  # is it possible that writing fails silently?
+  # anyhow, the test below won't hurt.
+  return 0 unless -e $f;
   unlink $f;
   return $written;
 }
@@ -286,7 +314,7 @@ sub get_user_path {
 #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 not used.
+#filename includes an extension. Currently only used for testing.
 #
 #=cut
 
@@ -323,9 +351,9 @@ sub add_to_path {
 
 =item C<add_texbindir_to_path>
 
-Remove any TeX directories from system path (if possible) and user
+Remove wrong TeX directories from system path (if possible) and user
 path. A directory is a TeX directory if it contains tex.exe or
-pdftex.exe.  Then add desired TeX directory; to system path if
+pdftex.exe.  Then if necessary add desired TeX directory; to system path if
 admin, otherwise to user path. wg_error gets set if there is a
 connflicting tex directory which cannot be removed from the path.
 
@@ -333,54 +361,145 @@ connflicting tex directory which cannot be removed from the path.
 
 sub add_texbindir_to_path {
   $wg_error = 0; # clear error status
-  $texbindir = shift;
-  my $syspath_temp = "";
+  my $texbindir = shift;
+
+  my $system_env = get_system_env();
+  my $user_env = get_user_env();
+  my $d;
   my $d_exp;
-  foreach $d (split (';', get_system_path())) {
-    $d_exp = expand_string($d);
-    $d_exp =~ s/\\/\//g;
-    $d_exp =~ s/\/$//;
-    if (is_a_texdir($d_exp)) {
-      if (!$is_admin and (uc($d_exp) ne uc($texbindir))) {
+  my $found = 0;
+  my @newp;
+  my $newp;
+
+  # system path
+  if ($is_admin) {
+    @newp = ();
+    foreach $d (split (';', get_system_path())) {
+      $d_exp = expand_string($d);
+      $d_exp =~ s/\\/\//g;
+      $d_exp =~ s/\/$//;
+      if (uc($d_exp) eq uc($texbindir)) {
+        push @newp, $d unless $found;
+        $found = 1;
+      } elsif (!is_a_texdir($d_exp)) {
+        push @newp, $d;
+      }
+    }
+    push @newp, $texbindir unless $found;
+    $found = 1;
+    $newp = join (';', @newp);
+    $newp =~ s/\//\\/g;
+    $system_env->ArrayValues(1); # use value_data, value_type pairs
+    $system_env -> {"/Path"} = [ $newp, REG_EXPAND_SZ ];
+  } else { # non-admin
+    # system path
+    foreach $d (split (';', get_system_path())) {
+      $d_exp = expand_string($d);
+      $d_exp =~ s/\\/\//g;
+      $d_exp =~ s/\/$//;
+      if (uc($d_exp) eq uc($texbindir)) {
+        $found = 1;
+      } elsif (is_a_texdir($d_exp)) {
         $wg_error = 1;
         $wg_error_message =
           "Warning: possibly conflicting [pdf]TeX program found at $d_exp\n";
+        tllog($::LOG_DEBUG, $wg_error_message);
       }
-    } elsif ($is_admin) {
-      $syspath_temp = add_to_path($syspath_temp, $d);
     }
   }
 
+  # user path
+  @newp = ();
+  foreach $d (split (';', get_user_path())) {
+    $d_exp = expand_string($d);
+    $d_exp =~ s/\\/\//g;
+    $d_exp =~ s/\/$//;
+    if (uc($d_exp) eq uc($texbindir)) {
+      push @newp, $d unless $found; # admin case: always $found
+      $found = 1;
+    } elsif (!is_a_texdir($d_exp)) {
+      push @newp, $d;
+    }
+  }
+  push @newp, $texbindir unless $found;
+  if (@newp) {
+    $newp = join ';', @newp;
+    $newp =~ s/\//\\/g;
+    $user_env->ArrayValues(1); # use value_data, value_type pairs
+    $user_env -> {"/Path"} = [ $newp,
+      ($newp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
+  } else {
+    delete $user_env -> {'/Path'};
+  }
+}
+
+sub remove_texbindir_from_path {
+  $wg_error = 0; # clear error status
+  $texbindir = shift;
+
+  my $system_env = get_system_env();
+  my $user_env = get_user_env();
+  my $d;
+  my $d_exp;
+  my @newp;
+  my $newp;
+
+  # system path
   if ($is_admin) {
-    $syspath_temp = add_to_path($syspath_temp, $texbindir);
-    $syspath_temp =~ s/\//\\/g;
-    my $system_env = get_system_env();
+    @newp = ();
+    foreach $d (split (';', get_system_path())) {
+      $d_exp = expand_string($d);
+      $d_exp =~ s/\\/\//g;
+      $d_exp =~ s/\/$//;
+      push @newp, $d unless (uc($d_exp) eq uc($texbindir));
+    }
+    $newp = join (';', @newp);
+    $newp =~ s/\//\\/g;
     $system_env->ArrayValues(1); # use value_data, value_type pairs
-    $system_env -> {"/Path"} = [ $syspath_temp, REG_EXPAND_SZ ];
+    $system_env -> {"/Path"} = [ $newp, REG_EXPAND_SZ ];
   }
 
-  # fix user path
-  # admin: remove any texdir but don't add anything
-  # user: remove any texdir and append new texdir
-
-  my $userpath_temp = "";
+  # user path
+  @newp = ();
   foreach $d (split (';', get_user_path())) {
     $d_exp = expand_string($d);
-    $userpath_temp = add_to_path($userpath_temp, $d) if (not is_a_texdir($d_exp));
+    $d_exp =~ s/\\/\//g;
+    $d_exp =~ s/\/$//;
+    push @newp, $d unless (uc($d_exp) eq uc($texbindir));
   }
-
-  $userpath_temp = add_to_path($userpath_temp, $texbindir) if !$is_admin;
-  if ($userpath_temp) {
-    $userpath_temp =~ s/\//\\/g;
-    my $user_env = get_user_env();
+  if (@newp) {
+    $newp = join(';', @newp);
+    $newp =~ s/\//\\/g;
     $user_env->ArrayValues(1); # use value_data, value_type pairs
-    $user_env -> {"/Path"} = [ $userpath_temp,
-    ($userpath_temp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
+    $user_env -> {"/Path"} = [ $newp,
+      ($newp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
   } else {
-    delete $user_env -> {'Path'};
+    delete $user_env -> {'/Path'};
   }
 }
 
+# delete a registry key recursively.
+# the key parameter should be a string, not a registry object.
+# We shall use this with file types.
+
+sub reg_delete_recurse {
+  my $parent = shift;
+  my $childname = shift;
+  tllog ($::LOG_DDDEBUG, "Deleting $childname regkey\n");
+  if ($childname !~ '^/') { # subkey
+    my $child = $parent->Open ($childname, {Access => KEY_ALL_ACCESS()});
+    foreach my $v (keys %$child) {
+      if ($v =~ '^/') { # value
+        delete $child->{$v};
+      } else { # subkey
+        reg_delete_recurse ($child, $v);
+      }
+    }
+    delete $child->{'/'};
+  }
+  delete $parent->{$childname};
+}
+
 =pod
 
 =item C<register_script_type>
@@ -396,33 +515,61 @@ sub register_script_type {
   $extension = uc($extension);
   my $command = shift;
   $command =~s/\//\\/g;
+  tllog ($::LOG_DDEBUG, "Linking $extension to $command\n");
+  my $user_env = get_user_env();
+  my $system_env = get_system_env();
+  my ($pathext, $found, $e, $classes_key);
 
   # pathext
-
-  my $pathext = get_user_env() -> {'/PATHEXT'};
-  $pathext = get_system_env() -> {'/PATHEXT'} if not $pathext;
-  my $found = 0;
-  foreach my $e (split(/;/,$pathext)) {
-    $found = 1 if (uc($e) eq $extension);
-  }
-  if (!$found) {
-    if ($is_admin) {
-      (get_system_env() -> {"/PATHEXT"}) = $pathext.";".$extension;
-        } else {
-      (get_user_env() -> {"/PATHEXT"}) = $pathext.";".$extension;
+  if ($is_admin) {
+    # system pathext
+    $pathext = $system_env -> {'/PATHEXT'};
+    $found = 0;
+    foreach $e (split(/;/,$pathext)) {
+      $found = 1 if (uc($e) eq $extension);
+    }
+    $system_env -> {'/PATHEXT'} = $pathext.";".$extension unless $found;
+    # user pathext
+    $pathext = $user_env -> {'/PATHEXT'};
+    if ($pathext) {
+      $found = 0;
+      foreach $e (split(/;/,$pathext)) {
+        $found = 1 if (uc($e) eq $extension);
+      }
+      $user_env -> {'/PATHEXT'} = $pathext.";".$extension unless $found;
     }
+  } else { # non-admin
+    $pathext = $user_env -> {'/PATHEXT'};
+    $pathext = $system_env -> {'/PATHEXT'} if not $pathext;
+    $found = 0;
+    foreach $e (split(/;/,$pathext)) {
+      $found = 1 if (uc($e) eq $extension);
+    }
+    $user_env -> {"/PATHEXT"} = $pathext.";".$extension unless $found;
   }
 
   # file type
-
   $extension = lc($extension);
-  my $classes_key = $Registry -> Open(
-    ($is_admin ? "LMachine/Software/Classes/" : "CUser/Software/Classes/"),
-    {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath";
-  $classes_key->ArrayValues(0);
-  $classes_key->CreateKey($extension)->SetValue("","script".$extension);
-  $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")->
-    SetValue("", '"'.$command.'" "%1" %*');
+  if ($is_admin) {
+    $classes_key = $Registry -> Open("LMachine/Software/Classes/",
+      {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath";
+    $classes_key->ArrayValues(0);
+    $classes_key->CreateKey($extension)->SetValue("","script".$extension);
+    $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")->
+      SetValue("", '"'.$command.'" "%1" %*');
+    # delete possibly conflicting values from HKCU/software
+    $classes_key = $Registry -> Open("CUser/Software/Classes/",
+        {Access => KEY_ALL_ACCESS()});
+    delete $classes_key -> {$extension};
+    reg_delete_recurse($classes_key, "script".$extension);
+  } else {
+    $classes_key = $Registry -> Open("CUser/Software/Classes/",
+        {Access => KEY_ALL_ACCESS()});
+    $classes_key->ArrayValues(0);
+    $classes_key->CreateKey($extension)->SetValue("","script".$extension);
+    $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")->
+      SetValue("", '"'.$command.'" "%1" %*');
+  }
 }
 
 =pod
@@ -434,34 +581,76 @@ Reversal of register_script_type.
 =cut
 
 sub unregister_script_type {
+  # we don't error check; we just do the best we can.
   my $extension = shift;
   $extension = '.'.$extension unless $extension =~ /^\./; # ensure leading dot
   $extension = uc($extension);
+  tllog ($::LOG_DDEBUG, "unregistering $extension\n");
+  my $user_env = get_user_env();
+  my $system_env = get_system_env();
+  my ($pathext, @newpe, $newpex, $e);
 
   # pathext
-  my $pathext = get_user_env() -> {'/PATHEXT'};
-  $pathext = get_system_env() -> {'/PATHEXT'} if not $pathext;
-  my @newpe;
-  foreach my $e (split(/;/,$pathext)) {
-    push @newpe, $e unless (uc($e) eq $extension);
-  }
-  my $newpe = join(";",@newpe);
+  tllog ($::LOG_DDEBUG, "Reverting PATHEXT\n");
   if ($is_admin) {
-    (get_system_env() -> {"/PATHEXT"}) = $newpe;
+    $pathext = $system_env -> {'/PATHEXT'};
+    @newpe = ();
+    foreach $e (split(/;/,$pathext)) {
+      push @newpe, $e unless (uc($e) eq $extension);
+    }
+    $newpex = join(";",@newpe);
+    $system_env -> {"/PATHEXT"} = $newpex;
+
+    $pathext = $user_env -> {'/PATHEXT'};
+    if ($pathext) {
+      @newpe = ();
+      foreach $e (split(/;/,$pathext)) {
+        push @newpe, $e unless (uc($e) eq $extension);
+      }
+      $newpex = join(";",@newpe);
+      if ($newpex eq ($system_env -> {"/PATHEXT"})) {
+        delete $user_env->{"/PATHEXT"};
+      } else {
+        $user_env -> {"/PATHEXT"} = $newpex;
+      }
+    }
   } else {
-    (get_user_env() -> {"/PATHEXT"}) = $newpe;
+    $pathext = $user_env -> {'/PATHEXT'};
+    $pathext = $system_env -> {'/PATHEXT'} unless $pathext;
+    @newpe = ();
+    foreach $e (split(/;/,$pathext)) {
+      push @newpe, $e unless (uc($e) eq $extension);
+    }
+    $newpex = join(";",@newpe);
+    if ($newpex eq ($system_env -> {"/PATHEXT"})) {
+      delete $user_env->{"/PATHEXT"};
+    } else {
+      $user_env -> {"/PATHEXT"} = $newpex;
+    }
   }
 
   # file type
+  tllog ($::LOG_DDEBUG, "Deleting texlua filetype\n");
   $extension = lc($extension);
-  my $classes_key = $Registry -> Open(
-    ($is_admin ? "LMachine/Software/Classes/" : "CUser/Software/Classes/"),
-    {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath";
-  delete $classes_key{$extension};
-  delete $classes_key{"script$extension"};
-  # $classes_key->CreateKey($extension)->SetValue("","script".$extension);
-  # $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")->
-  #  SetValue("", $command.' "%1" %*');
+  my $classes_key = $Registry -> Open("CUser/Software/Classes/",
+    {Access => KEY_ALL_ACCESS()});
+  if ($classes_key) {
+    reg_delete_recurse ($classes_key, $extension."/");
+    reg_delete_recurse ($classes_key, "script".$extension."/");
+  } else {
+    tllog ($::LOG_DDEBUG, "Cannot open HKCU classes for write\n");
+  }
+  if ($is_admin) {
+    $classes_key = $Registry -> Open("LMachine/Software/Classes/",
+    {Access => KEY_ALL_ACCESS()});
+    if ($classes_key) {
+      reg_delete_recurse ($classes_key, $extension."/");
+      reg_delete_recurse ($classes_key, "script".$extension."/");
+    } else {
+    tllog ($::LOG_DDEBUG, "Cannot open HKLM classes for write\n");
+    }
+    reg_delete_recurse ($classes_key, "script$extension");
+  }
 }
 
 =pod
@@ -477,15 +666,35 @@ processes they spawn.
 sub broadcast_env() {
   use constant HWND_BROADCAST	=> 0xffff;
   use constant WM_SETTINGCHANGE	=> 0x001A;
-  my @proto = ('SendMessage', 'LLPP', 'L');
   my $result = "";
   my $SendMessage;
   $wg_error = 0;
-  print "Broadcasting \"Enviroment settings changed\" message...\n";
-  $SendMessage = new Win32::API('user32', @proto);
+  tllog($::LOG_DDEBUG, "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;
-  print "Broadcast complete; result: $result.\n";
+  tllog ($::LOG_DDEBUG, "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) {
+    tllog ($::LOG_DDEBUG, "Notifying changes in filetypes...\n");
+    $update_fu->Call (SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0) if $update_fu;
+    tllog ($::LOG_DDEBUG, "Done notifying\n");
+  } else {
+    tllog ($::LOG_DDEBUG, "No update_fu\n");
+  }
 }
 
 =pod
@@ -499,9 +708,9 @@ sub broadcast_env() {
 
 __END__
 
-### Local Variables:
-### perl-indent-level: 2
-### tab-width: 2
-### indent-tabs-mode: nil
-### End:
-# vim:set tabstop=2 expandtab: #
+http://www.robvanderwoude.com/rundll.html:
+
+Activate registry changes in HKEY_CURRENT_USER without logging off
+(Windows 2000 and later):
+
+RUNDLL32.EXE USER32.DLL,UpdatePerUserSystemParameters ,1 ,True
diff --git a/Master/tlpkg/doc/wingoo-demo.bat b/Master/tlpkg/doc/wingoo-demo.bat
index a3589ba8d20..b3129d46771 100755
--- a/Master/tlpkg/doc/wingoo-demo.bat
+++ b/Master/tlpkg/doc/wingoo-demo.bat
@@ -1,31 +1,20 @@
 @echo off

 

-rem TeX Live Root; ends with backslash

+rem Directory of this script; ends with backslash

 rem This should also work with UNC names

-set tlroot=%~dp0

+set tldoc=%~dp0

 set tldrive=%~d0

 

 %tldrive%

-cd %tlroot%

+cd %tldoc%

 

-rem we need wget in the path, so add tlpkg\bin to the path

-set pathsave=%path%

-path %path%;%tlroot%tlpkg\bin

-

-rem use provided Perl

-

-set PERL5SAVE=%PERL5LIB%

-

-set PERL5LIB=%tlroot%tlpkg\lib\Perl5_lib-TL_inst

-"%tlroot%tlpkg\bin\perl" "%tlroot%wingoo-demo.pl"

+"%tldoc%..\tlperl\bin\perl" "%tldoc%wingoo-demo.pl"

 

 pause Done

 

 rem cleanup in case of start from command-line

 

-set PERL5LIB=%PERL5SAVE%

-set PERL5SAVE=

 path %pathsave%

 set pathsave=

 set tldrive=

-set tlroot=

+set tldoc=

diff --git a/Master/tlpkg/doc/wingoo-demo.pl b/Master/tlpkg/doc/wingoo-demo.pl
index 8e7359e0041..bcf4759d25d 100644
--- a/Master/tlpkg/doc/wingoo-demo.pl
+++ b/Master/tlpkg/doc/wingoo-demo.pl
@@ -1,8 +1,9 @@
 #!/usr/bin/env perl
-# For testing, edit $ro_dir and $wr_dir as needed.
+# For testing, edit $ro_dir and $luaprog as needed;
+# $ro_dir should be a read-only directory and
+# $luaprog should be a working lua executable but not texlua.
 
-# $ro_dir should be read-only.
-# $wr_dir should be writable.
+# Under Unix/Linux, just test whether loading of win32 modules is skipped.
 
 #!/usr/bin/env perl
 
@@ -14,29 +15,59 @@ BEGIN {
   $me=~s!\\!/!g if $^O=~/^MSWin(32|64)$/i;
 
   if ($me=~m!/!) {
-    ($::installerdir=$me)=~s!(.*)/.*$!$1!;
+    # wingoo-demo now in a subsubdirectory:
+    ($::installerdir=$me)=~s!(.*)\/tlpkg\/doc\/.*$!$1!;
   } else {
     # This shouldn't occur if called from batchfile
-    $::installerdir='.';
+    $::installerdir='./../..';
   }
+  @INC = ("$::installerdir/tlpkg/installer/perllib") if ($^O=~/^MSWin(32|64)$/i);
   unshift (@INC, "$::installerdir/tlpkg");
-  # unshift (@INC, "$::installerdir/bin/win32") if $^O=~/^MSWin(32|64)$/i;
 }
 
-use TeXLive::TLWinGoo; # safe under Unix/Linux!
+use TeXLive::TLUtils qw( get_system_tmpdir );
+use TeXLive::TLWinGooTry qw(
+  &admin
+  &non_admin
+  &admin_again
+  &dir_writable
+  &reg_country
+  &get_system_path
+  &get_user_path
+  &get_system_env
+  &get_user_env
+  &expand_string
+  &win_which_dir
+  &global_tmpdir
+  &add_texbindir_to_path
+  &remove_texbindir_from_path
+  &register_script_type
+  &unregister_script_type
+  &broadcast_env
+  &update_assocs
+  &wg_error
+); # safe under Unix/Linux!
 
 my $ro_dir = "z:/aps";
+my $luaprog = "x:/utils0/lua.exe";
+
+$::LOGLEVELTERMINAL=$::LOG_DDDEBUG;
+$::LOGLEVELFILE=$::LOG_ZERO;
 
 sub maybenot {
   my $bool = shift;
   return $bool ? " is " : " is not ";
 }
 
+# two uses:
+# - is the parent directory writable?
+# - is the script interpreted by lua or by texlua?
+
 sub create_file {
   my $name = shift;
   return if -e $name;
   open DUMMY, ">".$name;
-  print DUMMY "Hello";
+  print DUMMY "print(tostring(0.0000001))"; # lua: 1e-7; texlua: 0
   close DUMMY;
 }
 
@@ -45,28 +76,98 @@ sub print_search_paths {
   print "User path: ".get_user_path()."\n";
 }
 
-print ((join "\n", @INC)."\n");
+sub print_lua_out {
+  my $luatest = expand_string( $ENV{'TEMP'} ) . "/testlua";
+  create_file( $luatest . ".texlua" );
+  my $cmd = 'set PATHEXT=%PATHEXT%;.TEXLUA & "'.$luatest.'"';
+  $cmd =~ s/\//\\/g;
+  print "Lua[tex] result: ".`$cmd`."\n";
+  unlink $luatest.".texlua";
+}
+
+sub print_assoc_cmd {
+  my $ext = shift;
+  my $cmdout = `assoc $ext`;
+  chomp $cmdout if $cmdout;
+  if (!$cmdout) { print "Extension unknown\n"; return; }
+  my $ftype = $cmdout;
+  $ftype =~ s/.*=//;
+  if (!$ftype) { print "Extension unknown\n"; return; }
+  $cmdout = `ftype $ftype`;
+  if (!$cmdout) { print "Filetype unknown\n"; return; }
+  $cmdout =~ s/.*=//;
+  print( $ext.' command is: '.$cmdout."\n" );
+}
+
+sub print_config {
+  # system- and user settings for path, pathext
+  # and [HKCU|HKLM]\software\classes settings for e.g .rb
+  my $key;
+  my $val;
+
+  print_search_paths();
+
+  foreach $key (get_system_env(), get_user_env()) {
+    print ("Path: ".($key ->{'/path'})."\n");
+    print ("Expanded path: ".expand_string($key ->{'/path'})."\n");
+    print ("Pathext: ".($key->{'pathext'})."\n");
+  }
+
+  print_lua_out();
+
+  foreach $key ("LMachine/software/classes", "CUser/software/classes",
+      "Classes") {
+    print "Key: " . $key . "\n";
+
+    # system: lua; user: texlua
+    $val = $Win32::TieRegistry::Registry -> {$key."/.texlua//"};
+    print "Texlua filetype: ".$val."\n";
+    print "TeXlua open command: " .
+      $Win32::TieRegistry::Registry -> {$key."/".$val."/Shell/Open/Command/"} .
+      "\n";
+  }
+}
+
+sub pause {
+  my $mess = shift;
+  print( $mess."\nType any key..." );
+  read STDIN,my $dummy, 1;
+}
+
+### end of subs ###
+
+my $real_admin = admin();
+my $userpath_orig;
+my $systempath_orig;
+my $userpathext_orig;
+my $systempathext_orig;
+print( "\nGENERAL; ALSO UNIX\n" );
+
+print ( "\nINC\n" . (join "\n", @INC) . "\n\n");
+
 # admin
 
 if (admin()) {
-  print "Admin or not on Windows\n";
+  print "Admin or not_on_Windows\n";
 } else {
   print "Not admin\n";
 }
 
-# country
-
-print "Country: " . reg_country() . "\n";
-
 # global_tmpdir
 
-print "Global tempdir: " . global_tmpdir()."\n";
+print "\nGlobal tempdir: " . global_tmpdir()."\n";
 
 if ($^O !~ /^MSWin(32|64)$/i) {
   print "Not Windows; bailing out...\n";
   exit;
 }
 
+### end of non-windows
+
+# country
+
+print "Country: " . reg_country() . "\n";
+
 # dir_writable
 
 my $wr_dir = $ENV{'USERPROFILE'};
@@ -77,50 +178,102 @@ print $ro_dir . maybenot(dir_writable($ro_dir)) . "writable\n";
 
 # expand_string
 
+print( "\nExpansion\n" );
 print expand_string("pre\\%systemROOT%\\post")."\n";
 
 # win_which_dir
 
-print "cmd.exe found in " . TeXLive::TLWinGoo::win_which_dir("cmd.exe") . "\n";
-
-# adding and removing texbindir
-
-my $wr_dir1 = $wr_dir . "/tex1";
-mkdir $wr_dir1 unless -e $wr_dir1;
-create_file( $wr_dir1."/tex.exe" );
-add_texbindir_to_path($wr_dir1);
-print_search_paths();
-print "tex.exe found in " .
-  TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n";
-
-my $wr_dir2 = $wr_dir . "/tex2";
-mkdir $wr_dir2 unless -e $wr_dir2;
-create_file( $wr_dir2."/tex.exe" );
-add_texbindir_to_path($wr_dir2);
-print_search_paths();
-print "tex.exe found in " .
-  TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n";
-
-# the problem case: no admin, but TeX on system path
-
-my $admin_save = $TeXLive::TLWinGoo::is_admin;
-$TeXLive::TLWinGoo::is_admin = 0;
-my $fn = expand_string("%windir%")."/TEX.EXE";
-$fn =~ s/\\/\//g;
-create_file($fn); # a tex.exe on the system path!
-add_texbindir_to_path(expand_string($wr_dir2));
-my @wge = wg_error();
-if (@wge) {
-  print $wge[1]."\n";
-}
-print_search_paths();
-print "tex.exe found in " . TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n";
-unlink $fn;
+print( "\nFinding an executable\n" );
+print "cmd.exe found in " . win_which_dir("cmd.exe") . "\n";
+
+my $system_tmpdir=get_system_tmpdir();
+
+print( "\n\nHKCU and HKLM\n\n" );
+
+while (1) { # running this first as admin (if possible) and then as non-admin
+
+  print ((admin() ? "Is" : "Not") . " an admin\n");
+
+  # adding and removing texbindir
+
+  print( "\ntexbindir on searchpath\n" );
+  my $wr_dir1 = $wr_dir . "/tex1";
+  mkdir $wr_dir1 unless -e $wr_dir1;
+  create_file( $wr_dir1."/tex.exe" );
+  add_texbindir_to_path($wr_dir1);
+  print( "Take 1\n" );
+  print_search_paths();
+  print "tex.exe found in " . win_which_dir("tex.exe") . "\n";
+
+  my $wr_dir2 = $wr_dir . "/tex2";
+  mkdir $wr_dir2 unless -e $wr_dir2;
+  create_file( $wr_dir2."/tex.exe" );
+  add_texbindir_to_path($wr_dir2);
+  print( "Take 2\n" );
+  print_search_paths();
+  print "tex.exe found in " . win_which_dir("tex.exe") . "\n";
+
+  remove_texbindir_from_path( $wr_dir2 );
+  print( "Mopping up...\n" );
+  print_search_paths();
+
+  # adding a filetype
+
+  print( "\nRegistering and unregistering filetypes\n" );
+  my $testlua = admin() ? $luaprog : $::installerdir."/bin/win32/texlua.exe";
+  update_assocs(); # just to be sure
+  print_assoc_cmd( '.texlua' );
+  print_lua_out();
+  register_script_type(".texlua", $testlua );
+  update_assocs();
+  print_assoc_cmd( '.texlua' );
+  print_lua_out();
+  print( "Now unregister\n" );
+  unregister_script_type(".texlua");
+  update_assocs();
+  print_assoc_cmd( '.texlua' );
+  print_lua_out();
+  print( "Now re-register (not shown)\n" );
+  register_script_type(".texlua", $testlua );
+  update_assocs();
+
+  # broadcast environment changes
+
+  broadcast_env();
+  pause( "Check environment in new dosbox\n\n" );
+
+  if (admin()) {
+    non_admin();
+    next;
+  }
 
-# adding a filetype
+  # the problem case: no admin, but TeX on system path
 
-register_script_type(".rb","x:/ruby/bin/ruby.exe");
+  print( "\nNon-admin path problem\n" );
+  my $fn = expand_string("%windir%")."/TEX.EXE";
+  $fn =~ s/\\/\//g;
+  create_file($fn); # a tex.exe on the system path!
+  add_texbindir_to_path(expand_string($wr_dir2));
+  my @wge = wg_error();
+  if (@wge) {
+    print $wge[1]."\n";
+  }
+  print( "Cannot remove tex from system searchpath\n" );
+  print_search_paths();
+  print "tex.exe found in " . win_which_dir("tex.exe") . "\n";
+  unlink $fn;
+  remove_texbindir_from_path( $wr_dir2 );
+
+  # broadcast environment changes
 
-# broadcast environment changes
+  broadcast_env();
+  pause( "Check environment in new dosbox" );
+  if (!admin()) { last; }
+}
 
+admin_again();
+unregister_script_type(".texlua");
+update_assocs();
 broadcast_env();
+print_assoc_cmd( '.texlua' );
+