From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm | 1444 +++++++++++++++++++++++ 1 file changed, 1444 insertions(+) create mode 100644 systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm (limited to 'systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm') diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm new file mode 100644 index 0000000000..d39d0b37a4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm @@ -0,0 +1,1444 @@ +# $Id: TLWinGoo.pm 47907 2018-06-03 18:09:29Z karl $ +# TeXLive::TLWinGoo.pm - Windows goop. +# Copyright 2008-2018 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: 47907 $'; +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::is_vista; + TeXLive::TLWinGoo::is_seven; + TeXLive::TLWinGoo::is_ten; + TeXLive::TLWinGoo::admin; + TeXLive::TLWinGoo::non_admin; + TeXLive::TLWinGoo::reg_country; + +=head2 ENVIRONMENT AND REGISTRY + + TeXLive::TLWinGoo::expand_string($s); + 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::add_to_progids($ext, $filetype); + TeXLive::TLWinGoo::remove_from_progids($ext, $filetype); + 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); + +=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; + +=head2 ADMIN: MAKE INSTALLATION DIRECTORIES READ-ONLY + + TeXLive::TLWinGoo::maybe_make_ro($dir); + +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( + &is_vista + &is_seven + &is_ten + &admin + &non_admin + ); + @EXPORT_OK = qw( + &admin_again + ®_country + &broadcast_env + &update_assocs + &expand_string + &get_system_path + &get_user_path + &setenv_reg + &unsetenv_reg + &adjust_reg_path_for_texlive + &add_to_progids + &remove_from_progids + ®ister_extension + &unregister_extension + ®ister_file_type + &unregister_file_type + &shell_folder + &desktop_path + &add_desktop_shortcut + &add_menu_shortcut + &remove_desktop_shortcut + &remove_menu_shortcut + &create_uninstaller + &unregister_uninstaller + &maybe_make_ro + &get_system_env + &get_user_env + &is_a_texdir + &tex_dirs_on_path + ); + if ($^O=~/^MSWin/i) { + require Win32; + require Win32::API; + require Win32API::File; + require File::Spec; + require Win32::TieRegistry; + Win32::TieRegistry->import( qw( $Registry + REG_SZ REG_EXPAND_SZ REG_NONE KEY_READ KEY_WRITE KEY_ALL_ACCESS + KEY_ENUMERATE_SUB_KEYS ) ); + $Registry->Delimiter('/'); + $Registry->ArrayValues(0); + $Registry->FixSzNulls(1); + require Win32::OLE::NLS; + require Win32::Shortcut; + Win32::Shortcut->import( qw( SW_SHOWNORMAL SW_SHOWMINNOACTIVE ) ); + require Time::HiRes; + } +} # end BEGIN + +use TeXLive::TLConfig; +use TeXLive::TLUtils; +TeXLive::TLUtils->import( qw( mkdirhier ) ); + +sub reg_debug { + return if ($::opt_verbosity < 1); + my $mess = shift; + my $regerr = Win32API::Registry::regLastError(); + if ($regerr) { + debug("$regerr\n$mess"); + } +} + +my $is_win = ($^O =~ /^MSWin/i); + +# Win32: import some wrappers for API functions +# failed to get Win32::API::More to work with raw API functions; +# for now, use a tiny dll with perl-friendly wrappers + +# import failures return a null result; +# call imported functions only if true/non-null + +my $SendMessage = 0; +my $update_fu = 0; +if ($is_win) { + $SendMessage = new Win32::API('user32', 'SendMessageTimeout', 'LLPPLLP', 'L'); + debug ("Import failure SendMessage\n") unless $SendMessage; + $update_fu = new Win32::API('shell32', 'SHChangeNotify', 'LIPP', 'V'); + debug ("Import failure assoc_notify\n") unless $update_fu; +} + +=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; +my $windows_subversion = 0; + +if ($is_win) { + #my @osver = Win32::GetOSVersion(); # deprecated + #$windows_version = $osver[1]; + #debug "Windows version $osver[0], major version $osver[1]\n"; + my $ver = `ver`; + chomp $ver; + $ver =~ s/^[^0-9]*//; + $ver =~ s/[^0-9.]*$//; + ($windows_version = $ver) =~ s/\..*$//; + ($windows_subversion = $ver) =~ s/^[^\.]*\.//; + $windows_subversion =~ s/\..*$//; +} + +=item C + +C returns 1 if windows version is >= 6.0, otherwise 0. + +=cut + +sub is_vista { return $windows_version >= 6; } + +=item C + +C returns 1 if windows version is >= 6.1, otherwise 0. + +=cut + +sub is_seven { + return (($windows_version == 6 && $windows_subversion >= 1) || + ($windows_version > 6)); +} + +=item C + +C returns 1 if windows version is >= 10.0, otherwise 0. + +=cut + +sub is_ten { return $windows_version >= 10; } + +# permissions with which we try to access the system environment + +my $is_admin = 1; + +if ($is_win) { + $is_admin = 0 unless Win32::IsAdminUser(); +} + +sub KEY_FULL_ACCESS() { + return KEY_WRITE() | KEY_READ(); +} + +sub sys_access_permissions { + return $is_admin ? KEY_FULL_ACCESS() : KEY_READ(); +} + +sub get_system_env { + return $Registry -> Open( + "LMachine/system/currentcontrolset/control/session manager/Environment/", + {Access => sys_access_permissions()}); +} + +sub get_user_env { + return $Registry -> Open("CUser/Environment", {Access => KEY_FULL_ACCESS()}); +} + +=pod + +=item C + +Returns admin status, admin implying having full read-write access +to the system environment. + +=cut + +# during processing of this source, $is_admin will get its correct value + +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 = Win32::OLE::NLS::GetUserDefaultLangID(); + return unless $value; + $value = sprintf ("%04x", $value); + my $lmkey = $Registry -> Open("HKEY_CLASSES_ROOT/MIME/Database/Rfc1766/", + {Access => KEY_READ()}); + return unless $lmkey; + $lm = $lmkey->{"/$value"}; + return 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 { + my $lang = lc(substr $lm, 0, 2); + my $area = lc(substr $lm, 3, 2); + return($lang, $area); + } + } +} + + +=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) = @_; + return Win32::ExpandEnvironmentStrings($s); +} + +my $global_tmp = $is_win ? expand_string(get_system_env()->{'TEMP'}) : "/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 + +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 + +# short path names should be unique + +sub short_name { + my ($fname) = @_; + return $fname unless $is_win; + # GetShortPathName may return undefined, e.g. if $fname does not exist, + # e.g. because of temporary unavailability of a network- or portable drive, + # which should not be considered a real error + my $shname = Win32::GetShortPathName ($fname); + return (defined $shname) ? $shname : $fname; +} + +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: compare $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; +} + +### File types ### + +# Refactored from 2010 edition. New functionality: +# add_to_progids for defining alternate filetypes for an extension. +# Their associated programs show up in the `open with' right-click menu. + +### helper subs ### + +# merge recursive hash refs such as occur in the registry + +sub hash_merge { + my $target = shift; # the recursive hash ref to be modified by $mods + my $mods = shift; # the recursive hash ref to be merged into $target + my $k; + foreach $k (keys %$mods) { + if (ref($target->{$k}) eq 'HASH' and ref($mods->{$k}) eq 'HASH') { + hash_merge($target->{$k}, $mods->{$k}); + } else { + $target->{$k} = $mods->{$k}; + reg_debug ("at hash merge\n"); + $target->Flush(); + reg_debug ("at hash merge\n"); + } + } +} + +# prevent catastrophies during testing; not to be used in production code + +sub getans { + my $prompt = shift; + my $ans; + print STDERR "$prompt "; + $ans = ; + if ($ans =~ /^y/i) {print STDERR "\n"; return 1;} + die "Aborting as requested"; +} + +# delete a registry key recursively. +# the key parameter should be a string, not a registry object. + +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_FULL_ACCESS()}); + reg_debug ("at open $childname for all access\n"); + return 1 unless defined($child); + foreach my $v (keys %$child) { + if ($v =~ '^/') { # value + delete $child->{$v}; + reg_debug ("at delete $childname/$v\n"); + $child->Flush(); + reg_debug ("at delete $childname/$v\n"); + Time::HiRes::usleep(20000); + } else { # subkey + return 0 unless reg_delete_recurse ($child, $v); + } + } + #delete $child->{'/'}; + } + delete $parent->{$childname}; + reg_debug ("at delete $parentpath$childname\n"); + $parent->Flush(); + reg_debug ("at delete $parentpath$childname\n"); + Time::HiRes::usleep(20000); + return 1; +} + +sub cu_root { + my $k = $Registry -> Open("CUser", { + Access => KEY_FULL_ACCESS(), Delimiter => '/' + }); + reg_debug ("at open HKCU for all access\n"); + die "Cannot open HKCU for writing" unless $k; + return $k; +} + +sub lm_root { + my $k = $Registry -> Open("LMachine", { + Access => ($is_admin ? KEY_FULL_ACCESS() : KEY_READ()), + Delimiter => '/' + }); + reg_debug ("at open HKLM\n"); + die "Cannot open HKLM for ".($is_admin ? "writing" : "reading") + unless $k; + return $k; +} + +sub do_write_regkey { + my $keypath = shift; # modulo cu/lm + my $keyhash = shift; # ref to a possibly nested hash; empty hash allowed + my $remove_cu = shift; + die "No regkey specified" unless $keypath && defined($keyhash); + # for error reporting: + my $hivename = $is_admin ? 'HKLM' : 'HKCU'; + + # 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 $parentkey; + + # make sure parent exists + if ($is_admin) { + $parentkey = $lm_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); + if (!$parentkey) { + # in most cases, this probably shouldn't happen for lm + $parentkey = $lm_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); + } + } else { + $parentkey = $cu_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); + if (!$parentkey) { + $parentkey = $cu_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); + } + } + if (!$parentkey) { + tlwarn "Cannot create parent of $hivename/$keypath\n"; + return 0; + } + + # create or merge key + if ($parentkey->{$keyname}) { + hash_merge($parentkey->{$keyname}, $keyhash); + } else { + $parentkey->{$keyname} = $keyhash; + reg_debug ("at creating $keyname\n"); + } + if (!$parentkey->{$keyname}) { + tlwarn "Failure to create $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$keypath} and $remove_cu) { + # delete possibly conflicting cu key + tlwarn "Failure to delete $hivename/$keypath key\n" unless + reg_delete_recurse ($cu_key->{$parentpath}, $keyname); + } + return 1; +} + +# remove a registry key under HKCU or HKLM, depending on privilege level + +sub do_remove_regkey { + my $keypath = shift; # key or value + my $remove_cu = shift; + my $hivename = $is_admin ? 'HKLM' : 'HKCU'; + + my $parentpath = ""; + my $keyname = ""; + my $valname = ""; + # two successive delimiters: value. + # *? = non-greedy match: want FIRST double delimiter + if ($keypath =~ /^(.*?\/)(\/.*)$/) { + ($parentpath, $valname) = ($1, $2); + $parentpath =~ s!^/!!; # remove leading delimiter + } elsif ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { + ($parentpath, $keyname) = ($1, $2); + $keyname .= '/'; + } else { + die "Cannot determine final component of $keypath"; + } + + my $cu_key = cu_root(); + my $lm_key = lm_root(); + my ($parentkey, $k, $skv, $d); + if ($is_admin) { + $parentkey = $lm_key->Open($parentpath); + } else { + $parentkey = $cu_key->Open($parentpath); + } + reg_debug ("at opening $parentpath\n"); + if (!$parentkey) { + debug ("$hivename/$parentpath not present or not writable". + " so $keypath not removed\n"); + return 1; + } + if ($keyname) { + #getans("Deleting $parentpath$keyname regkey? "); + reg_delete_recurse($parentkey, $keyname); + if ($parentkey->{$keyname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + reg_delete_recurse($cu_key->{$parentpath}, $keyname); + if ($cu_key->{$parentpath}->{$keyname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } + } + } else { + delete $parentkey->{$valname}; + reg_debug ("at deleting $valname\n"); + if ($parentkey->{$valname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + delete $cu_key->{$parentpath}->{$valname}; + reg_debug ("at deleting $valname\n"); + if ($cu_key->{$parentpath}->{$valname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } + } + } + return 1; +} + +############################# +# not overwriting an existing file association + +# read error is sometimes access_denied, +# therefore we ONLY decide that a value does not exist if +# an attempt to read it errors out with file_not_found. + +# windows error codes +my $file_not_found = 2; # ERROR_FILE_NOT_FOUND +my $reg_ok = 0; # ERROR_SUCCESS + +# inaccessible value (note. actual filetypes shound not have spaces) +my $reg_unknown = 'not accessible'; + +# Effective default value of any key under Classes. +# admin: HKLM; user: HKCU or otherwise HKLM +sub current_filetype { + my $extension = shift; + my $filetype; + my $regerror; + + if ($is_admin) { + $regerror = $reg_ok; + $filetype = lm_root()->{"Software/Classes/$extension//"} # REG_SZ + or $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + } else { + # Mysterious failures on w7_64 => merge HKLM/HKCU info explicitly + # rather than checking HKCR + $regerror = $reg_ok; + $filetype = cu_root()->{"Software/Classes/$extension//"} or + $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + if (!defined($filetype) or ($filetype eq "")) { + $regerror = $reg_ok; + $filetype = lm_root()->{"Software/Classes/$extension//"} or + $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + }; + } + $filetype = "" unless defined($filetype); + return $filetype; +} + +### now the exported file type functions ### + +=pod + +=item C + +Add $filetype to the list of alternate progids/filetypes of extension $ext. +The associated program shows up in the `open with' right-click menu. + +=cut + +sub add_to_progids { + my $ext = shift; + my $filetype = shift; + #$Registry->ArrayValues(1); + #do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + # {"/$filetype" => [0, REG_NONE()]}); + #$Registry->ArrayValues(0); + do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + {"/$filetype" => ""}); +} + +=pod + +=item C + +Remove $filetype from the list of alternate filetypes for $ext + +=cut + +sub remove_from_progids { + my $ext = shift; + my $filetype = shift; + do_remove_regkey("Software/Classes/$ext/OpenWithProgIds//$filetype"); +} + +=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. + +For $mode 1, the filetype for the extension is preserved, but only +if there is a registry key under Classes for it. For $mode>0, +the new filetype is always added to the openwithprogids list. + +For $mode 2, the filetype is always overwritten. The old filetype +moves to the openwithprogids list if necessary. + +=cut + +sub register_extension { + my $mode = shift; + return 1 if $mode == 0; + my $extension = shift; + # ensure leading dot + $extension = '.'.$extension unless $extension =~ /^\./; + $extension = lc($extension); + my $file_type = shift; + my $regkey; + + my $old_file_type = current_filetype($extension); + if ($old_file_type and $old_file_type ne $reg_unknown) { + if ($is_admin) { + if (not lm_root()->{"Software/Classes/$old_file_type/"}) { + $old_file_type = ""; + } + } else { + if ((not cu_root()->{"Software/Classes/$old_file_type/"}) and + (not lm_root()->{"Software/Classes/$old_file_type/"})) { + $old_file_type = ""; + } + } + } + # admin: whether to remove HKCU entry. admin never _writes_ to HKCU + my $remove_cu = ($mode == 2) && admin(); + + # can do the following safely: + debug ("Adding $file_type to OpenWithProgIds of $extension\n"); + add_to_progids ($extension, $file_type); + + if ($old_file_type and $old_file_type ne $file_type) { + if ($mode == 1) { + debug ("Not overwriting $old_file_type with $file_type for $extension\n"); + } else { # $mode ==2, overwrite + debug("Linking $extension to $file_type\n"); + if ($old_file_type ne $reg_unknown) { + debug ("Moving $old_file_type to OpenWithProgIds\n"); + add_to_progids ($extension, $old_file_type); + } + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu); + } + } else { + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu); + } +} + +=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; + return 1 if $mode == 0; + # mode 1 and 2 treated identically: + # only unregister if the current value is as expected + my $extension = shift; + my $file_type = shift; + $extension = '.'.$extension unless $extension =~ /^\./; + remove_from_progids($extension, $file_type); + my $old_file_type = current_filetype("$extension"); + if ($old_file_type ne $file_type) { + debug("Filetype $extension now $old_file_type; not ours, so not removed\n"); + return 1; + } else { + debug("unregistering extension $extension\n"); + do_remove_regkey("Software/Classes/$extension//"); + } +} + +=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; + tlwarn "register_file_type called with empty command\n" unless $command; + $command =~s!/!\\!g; + debug ("Linking $file_type to $command\n"); + my $keyhash = { + "shell/" => { + "open/" => { + "command/" => { + "/" => $command + } + } + } + }; + do_write_regkey("Software/Classes/$file_type", $keyhash); +} + +=pod + +=item C + +Reversal of register_file_type. + +=cut + +sub unregister_file_type { + # we don't error check; we just do the best we can. + # All our filetypes start with 'TL.' so we consider them + # our own even if they have been tampered with. + my $file_type = shift; + debug ("unregistering $file_type\n"); + do_remove_regkey("Software/Classes/$file_type/"); +} + +=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() { + if ($SendMessage) { + use constant HWND_BROADCAST => 0xffff; + use constant WM_SETTINGCHANGE => 0x001A; + my $result = ""; + 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"); + } else { + debug("No SendMessage available\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; + 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 + +=over 4 + +=item C + +Add a 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. + +=item C + +Add a shortcut on the desktop. + +=item C + +Add a menu shortcut at place $place, relative to Start/Programs. + +=cut + +sub add_shortcut { + my ($dir, $name, $icon, $prog, $args, $batgui) = @_; + + # make sure $dir exists + if ((not -e $dir) and (not -d $dir)) { + mkdirhier($dir); + } + if (not -d $dir) { + tlwarn ("Failed to create directory $dir for shortcut\n"); + return; + } + # create shortcut + debug "Creating shortcut $name for $prog in $dir\n"; + 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; + $shc->{'WorkingDirectory'} = '%USERPROFILE%'; + $shfile = $dir; + $shfile =~ s!\\!/!g; + $shfile .= ($shfile =~ m!/$! ? '' : '/') . $name . '.lnk'; + $shc->Save($shfile); +} + +sub desktop_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_DESKTOPDIRECTORY : + Win32::CSIDL_DESKTOPDIRECTORY), CREATE); +} + +sub menu_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_PROGRAMS : Win32::CSIDL_PROGRAMS), CREATE); +} + +sub add_desktop_shortcut { + my ($name, $icon, $prog, $args, $batgui) = @_; + add_shortcut (desktop_path(), $name, $icon, $prog, $args, $batgui); +} + +sub add_menu_shortcut { + my ($place, $name, $icon, $prog, $args, $batgui) = @_; + $place =~ s!\\!/!g; + my $shdir = menu_path() . ($place =~ m!^/!=~ '/' ? '' : '/') . $place; + add_shortcut ($shdir, $name, $icon, $prog, $args, $batgui); +} + + +=pod + +=item C + +For uninstallation of an individual package. + +=item C + +For uninstallation of an individual package. + +=cut + +sub remove_desktop_shortcut { + my $name = shift; + unlink desktop_path().'/'.$name.'.lnk'; +} + +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 { + # TEXDIR + &log("Creating uninstaller\n"); + my $td_fw = shift; + $td_fw =~ s!\\!/!; + my $td = $td_fw; + $td =~ s!/!\\!g; + + my $tdmain = `"$td\\bin\\win32\\kpsewhich" -var-value=TEXMFMAIN`; + $tdmain =~ s!/!\\!g; + chomp $tdmain; + + my $uninst_fw = "$td_fw/tlpkg/installer"; + my $uninst_dir = $uninst_fw; + $uninst_dir =~ s!/!\\!g; + mkdirhier("$uninst_fw"); # wasn't this done yet? + if (! (open UNINST, ">", "$uninst_fw/uninst.bat")) { + tlwarn("Failed to create uninstaller\n"); + return 0; + } + print UNINST <nul 2>&1 +if not errorlevel 1 1>nul 2>&1 taskkill /IM tl-tray-menu.exe /f +copy \"$uninst_dir\\uninst2.bat\" \"\%TEMP\%\" +rem pause +\"\%TEMP\%\\uninst2.bat\" +UNEND +; + close UNINST; + + # We could simply delete everything under the root at one go, + # but this might be catastrophic if TL doesn't have its own root. + if (! (open UNINST2, ">$uninst_fw/uninst2.bat")) { + tlwarn("Failed to complete creating uninstaller\n"); + return 0; + } + print UNINST2 < Open((admin() ? "LMachine" : "CUser") . + "/software/microsoft/windows/currentversion/", + {Access => KEY_FULL_ACCESS()}); + if ($uninst_key) { + $k = $uninst_key->CreateKey( + "uninstall/TeXLive$::TeXLive::TLConfig::ReleaseYear/"); + if ($k) { + $k->{"/DisplayName"} = "TeX Live $::TeXLive::TLConfig::ReleaseYear"; + $k->{"/UninstallString"} = "\"$td\\tlpkg\\installer\\uninst.bat\""; + $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear; + $k->{'/Publisher'} = 'TeX Live'; + $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive"; + } + } + if (!$k and admin()) { + tlwarn("Failed to register uninstaller\n". + "You can still run $td\\tlpkg\\installer\\uninst.bat manually.\n"); + return 0; + } + } +} + +=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_FULL_ACCESS()}); + reg_delete_recurse( + $regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/") + if $regkey_uninst; + tlwarn "Failure to unregister uninstaller\n" if + $regkey_uninst->{"TeXLive$::TeXLive::TLConfig::ReleaseYear/"}; +} + +=pod + +=item C + +Write-protects a directory $dir recursively, using ACLs, but only if +we are a multi-user install, and only if $dir is on an +NTFS-formatted local fixed disk, and only on Windows Vista and +later. It writes a log message what it does and why. + +=cut + +sub maybe_make_ro { + my $dir = shift; + debug ("Calling maybe_make_ro on $dir\n"); + tldie "$dir not a directory\n" unless -d $dir; + if (!admin()) { + log "Not an admin install; not making read-only\n"; + return 1; + } + if (!is_vista()) { + log "Windows version $windows_version earlier than Vista;". + " not making read-only\n"; + return 1; + } + + $dir = Cwd::abs_path($dir); + + # GetDriveType: check that $dir is on local fixed disk + # need to feed GetDriveType the drive root + my ($volume,$dirs,$file) = File::Spec->splitpath($dir); + debug "Split path: | $volume | $dirs | $file\n"; + # GetDriveType won't handle UNC paths so handle this case separately + if ($volume =~ m!^[\\/][\\/]!) { + log "$dir on UNC network path; not making read-only\n"; + return 1; + } + my $dt = Win32API::File::GetDriveType($volume); + debug "Drive type $dt\n"; + if ($dt ne Win32API::File::DRIVE_FIXED) { + log "Not a local fixed drive; not making read-only\n"; + return 1; + } + + # FsType: test for NTFS, or, better, check whether ACLs are supported + # FsType needs to be called for the current directory + my $curdir = Cwd::getcwd(); + debug "Current directory $curdir\n"; + chdir $dir; + my $newdir = Cwd::getcwd(); + debug "New current directory $newdir\n"; + tldie "Cannot cd to $dir, current dir is $newdir\n" unless + lc($newdir) eq lc($dir); + my ($fstype, $flags, $maxl) = Win32::FsType(); # of current drive + if (!($flags & 0x00000008)) { + log "$dir does not supports ACLs; not making read-only\n"; + # go back to original directory + chdir $curdir; + return 1; + } + + # ran out of excuses: do it + # we use cmd /c + # $dir now being the current directory, we can save ourselves + # some quoting troubles by using . for $dir. + + # some 'well-known sids': + # S-1-5-11 Authenticated users + # S-1-5-32-545 Users + # S-1-5-32-544 administrators + # S-1-3-0 creator owner + # S-1-3-1 creator group + + # useful explanations at http://timbolton.net/2010/06/23/ + # /icacls-changing-permissions-on-files-and-folders + + # /reset is necessary for removing non-standard existing permissions + my $cmd = 'cmd /c "icacls . /reset && icacls . /inheritance:r'. + ' /grant:r *S-1-5-32-544:(OI)(CI)F /grant *S-1-3-0:(OI)(CI)F'. + ' /grant *S-1-5-11:(OI)(CI)RX"'; + log "Making read-only\n".`$cmd`."\n"; + + # go back to original directory + chdir $curdir; + return 1; +} + +# 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: # -- cgit v1.2.3