summaryrefslogtreecommitdiff
path: root/Master
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2008-02-25 15:53:19 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2008-02-25 15:53:19 +0000
commit783675c0cb64a4e6e625b7a4e37c320eaf17fb8d (patch)
tree201360ff7d83762855e41647eb386ec4632f9a16 /Master
parent506efaea286d392d8c49a0c4cff49f06a791171b (diff)
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
Diffstat (limited to 'Master')
-rwxr-xr-xMaster/install-tl.pl17
-rw-r--r--Master/tlpkg/TeXLive/TLWinGoo.pm379
-rwxr-xr-xMaster/tlpkg/doc/wingoo-demo.bat21
-rw-r--r--Master/tlpkg/doc/wingoo-demo.pl259
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' );
+