From 7490c4031eb53f351c26bc65ab79b3c1daf81457 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 7 Apr 2016 12:25:35 +0000 Subject: Updates for Windows, esp. making TL read-only for admin installs git-svn-id: svn://tug.org/texlive/trunk@40301 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLWinGoo.pm | 374 ++++++++++++++++++++------------------ Master/tlpkg/installer/tl-cmd.bat | 2 - Master/tlpkg/tlpostcode/xetex.pl | 4 +- 3 files changed, 202 insertions(+), 178 deletions(-) (limited to 'Master/tlpkg') diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm index e5a48e867ed..0ee3f65ec3d 100644 --- a/Master/tlpkg/TeXLive/TLWinGoo.pm +++ b/Master/tlpkg/TeXLive/TLWinGoo.pm @@ -1,6 +1,6 @@ # $Id$ # TeXLive::TLWinGoo.pm - Windows nastiness -# Copyright 2008-2014 Siep Kroonenberg, Norbert Preining +# Copyright 2008-2014, 2016 Siep Kroonenberg, Norbert Preining # This file is licensed under the GNU General Public License version 2 # or any later version. @@ -76,6 +76,10 @@ C -- Additional utilities for Windows 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 @@ -117,6 +121,7 @@ BEGIN { &remove_menu_shortcut &create_uninstaller &unregister_uninstaller + &maybe_make_ro ); # for testing also: @EXPORT_OK = qw( @@ -128,7 +133,10 @@ BEGIN { &tex_dirs_on_path ); if ($^O=~/^MSWin(32|64)$/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 @@ -136,11 +144,12 @@ BEGIN { $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; @@ -157,6 +166,22 @@ sub reg_debug { my $is_win = $^O=~/^MSWin(32|64)$/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 $assoc_fu; +} + =pod =back @@ -175,10 +200,9 @@ registry: 5.0 for Windows 2000, 5.1 for Windows XP and 6.0 for Vista. my $windows_version = 0; if ($is_win) { - my $tempkey = $Registry->Open( - "LMachine/software/Microsoft/Windows NT/CurrentVersion/", - {Access => KEY_READ() }); - $windows_version = $tempkey -> { "/CurrentVersion" }; + my @osver = Win32::GetOSVersion(); + $windows_version = $osver[1]; + debug "Windows version $osver[0], major version $osver[1]\n"; } sub win_version { return $windows_version; } @@ -195,6 +219,10 @@ sub is_vista { return $windows_version >= 6; } my $is_admin = 1; +if ($is_win) { + $is_admin = 0 unless Win32::IsAdminUser(); +} + sub KEY_FULL_ACCESS() { return KEY_WRITE() | KEY_READ(); } @@ -209,17 +237,6 @@ sub get_system_env { {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_FULL_ACCESS()}); } @@ -268,12 +285,9 @@ Two-letter country code representing the locale of the current user =cut sub reg_country { - my $value = $Registry -> {"CUser/Control Panel/International//Locale"}; - return unless $value; - # there might be trailing nulls on Vista - $value =~ s/\x00*$//; - $value = substr $value, -4; + 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; @@ -328,8 +342,7 @@ values as environment variable and returns the result. sub expand_string { my ($s) = @_; - $s =~ s/%([^%;]+)%/$ENV{$1} ? $ENV{$1} : "%$1%"/eg; - return $s; + return Win32::ExpandEnvironmentStrings($s); } =pod @@ -395,32 +408,6 @@ sub get_user_path { 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 @@ -510,6 +497,23 @@ to system or user PATH variable in the registry (depending on $mode). =cut +# short path names should be unique + +#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; + # 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") @@ -527,7 +531,7 @@ sub adjust_reg_path_for_texlive { 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"); + ddebug("adjust_reg: compare $d_short with $tlbindir_short\n"); if ($d_short ne $tlbindir_short) { push(@newpath, $d); if (is_a_texdir($d)) { @@ -996,19 +1000,17 @@ 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"); + 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 @@ -1022,7 +1024,6 @@ Notifies the system that filetypes have changed. 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); @@ -1038,135 +1039,85 @@ sub update_assocs() { =head2 SHORTCUTS -=cut - -# short path names +=item C -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 +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_desktop_shortcut { - my ($name, $icon, $prog, $args, $batgui) = @_; +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; - $shfile = desktop_path().'/'.$name.'.lnk'; + $shc->{'WorkingDirectory'} = '%USERPROFILE%'; + $shfile = $dir; + $shfile =~ s!\\!/!g; + $shfile .= ($shfile =~ m!/$! ? '' : '/') . $name . '.lnk'; $shc->Save($shfile); } -=pod - -=item C +sub desktop_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_DESKTOPDIRECTORY : + Win32::CSIDL_DESKTOPDIRECTORY), CREATE); +} -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. +sub menu_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_PROGRAMS : Win32::CSIDL_PROGRAMS), CREATE); +} -=cut +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 ($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)) { - tlwarn("Failed to create shortcut for $name\n"); - next; # continue regardless - } elsif (not (-d $shpath)) { - mkdirhier($shpath); - return unless -d $shpath; - } - $shfile = $shpath.'/'.$name.'.lnk'; - $shc->Save($shfile); + 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 { @@ -1174,14 +1125,6 @@ sub remove_desktop_shortcut { 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; @@ -1210,22 +1153,24 @@ sub create_uninstaller { # TEXDIR &log("Creating uninstaller\n"); my $td_fw = shift; - $td_fw =~ s![\\/]$!!; + $td_fw =~ s!\\!/!; my $td = $td_fw; $td =~ s!/!\\!g; - my $tdmain = `$td\\bin\\win32\\kpsewhich -var-value=TEXMFMAIN`; + my $tdmain = `"$td\\bin\\win32\\kpsewhich" -var-value=TEXMFMAIN`; + $tdmain =~ s!/!\\!g; chomp $tdmain; my $uninst_fw = "$td_fw/tlpkg/installer"; - my $uninst_dir = TeXLive::TLUtils::conv_to_w32_path($uninst_fw); + 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 < + +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-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; diff --git a/Master/tlpkg/installer/tl-cmd.bat b/Master/tlpkg/installer/tl-cmd.bat index 4102c7b757f..747d3088239 100755 --- a/Master/tlpkg/installer/tl-cmd.bat +++ b/Master/tlpkg/installer/tl-cmd.bat @@ -11,7 +11,5 @@ setlocal enableextensions rem Add bin dir to beginning of PATH only if it is not already there for /f "tokens=1,2 delims=;" %%I in ("%~dp0..\..\bin\win32;%PATH%") do if not "%%~fI"=="%%~fJ" set "PATH=%%~fI;%PATH%" -cd /d %HOMEDRIVE%%HOMEPATH% - rem Start new console start "TeX Live" "%COMSPEC%" diff --git a/Master/tlpkg/tlpostcode/xetex.pl b/Master/tlpkg/tlpostcode/xetex.pl index ac109c5c515..4a28008bb1a 100644 --- a/Master/tlpkg/tlpostcode/xetex.pl +++ b/Master/tlpkg/tlpostcode/xetex.pl @@ -10,11 +10,13 @@ my $texdir; my $mode; +my $skip_gen; # not used for (un)install BEGIN { $^W = 1; $mode = lc($ARGV[0]); $texdir = $ARGV[1]; + $skip_gen = (defined $ARGV[2]) ? 1 : 0; # not used with normal installs # make Perl find our packages first: unshift (@INC, "$texdir/tlpkg"); } @@ -80,7 +82,7 @@ sub do_install { warn("open($texdir/tlpkg/tlpostcode/xetex/conf/fonts.conf) failed: $!"); } } - if (win32()) { + if (win32() && !$skip_gen) { # call fc-cache but only when we install on w32! info("Running fc-cache -v -r\n"); log( `fc-cache -v -r 2>&1` ); # run it, log output -- cgit v1.2.3