From 781722be9a2864a2da136d37b2809d44115bc1a9 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sat, 23 Apr 2011 10:08:45 +0000 Subject: Proposed update TLWinGoo git-svn-id: svn://tug.org/texlive/trunk@22173 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm | 1286 ++++++++++++++++++++++++++++++ Master/tlpkg/dev/tlwingoonew/testw32 | 132 +++ Master/tlpkg/dev/tlwingoonew/testw32.bat | 5 + 3 files changed, 1423 insertions(+) create mode 100644 Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm create mode 100644 Master/tlpkg/dev/tlwingoonew/testw32 create mode 100755 Master/tlpkg/dev/tlwingoonew/testw32.bat (limited to 'Master/tlpkg/dev') 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 -- 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 + ®_country + &expand_string + &global_tmpdir + &get_system_path + &get_user_path + &setenv_reg + &unsetenv_reg + &adjust_reg_path_for_texlive + ®ister_extension + &unregister_extension + ®ister_file_type + &unregister_file_type + ®ister_application + &unregister_application + &add_to_openwithlist + &remove_from_openwithlist + &broadcast_env + &update_assocs + &shell_folder + &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 + +C 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 + +C 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 + +Returns admin status, admin implying having full read-write access +to the system environment. + +=cut + +sub admin { return $is_admin; } + +=pod + +=item C + +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 + +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 + +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 + +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 + +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 + +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 +# +#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 + +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 + +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 + +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 + +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 = ; + 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 + +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 + +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 + +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 + +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 + +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 + +Reversal of register_application + +=cut + +sub unregister_application { + my $prog = shift; + do_remove_regkey(2, "Software/Classes/Applications/$prog/"); +} + +=pod + +=item C + +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 $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 + +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 + +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 + +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 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 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 + +For uninstallation of an individual package. + +=cut + +sub remove_desktop_shortcut { + my $name = shift; + unlink desktop_path().'/'.$name.'.lnk'; +} + +=pod + +=item C + +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 + +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 <$tdwfw/tlpkg/installer/uninst2.bat") { + print UNINST2 <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 + +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 -- cgit v1.2.3