diff options
Diffstat (limited to 'Master/tlpkg/dev')
-rw-r--r-- | Master/tlpkg/dev/tlwingoonew/README | 1 | ||||
-rw-r--r-- | Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm | 1286 |
2 files changed, 0 insertions, 1287 deletions
diff --git a/Master/tlpkg/dev/tlwingoonew/README b/Master/tlpkg/dev/tlwingoonew/README index 88f266406ea..5ea6bc33add 100644 --- a/Master/tlpkg/dev/tlwingoonew/README +++ b/Master/tlpkg/dev/tlwingoonew/README @@ -1,4 +1,3 @@ Testing: -- replace original TLWinGoo with this one - put testw32[.bat] in root of installation or svn/rsync checkout diff --git a/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm b/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm deleted file mode 100644 index bd15e2d517f..00000000000 --- a/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm +++ /dev/null @@ -1,1286 +0,0 @@ -# $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 - ®_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<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: # |