# TeXLive::TLWinGoo.pm # Windows nastiness # # Copyright 2008 Siep Kroonenberg, Norbert Preining # This file is licensed under the GNU General Public License version 2 # or any later version. # code for broadcast_env adopted 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; =pod =head1 NAME C -- Additional utilities for Windows =head2 SYNOPSIS use TeXLive::TLWinGoo; =head2 ERROR HANDLING TeXLive::TLWinGoo::wg_error; =head2 DIAGNOSTICS TeXLive::TLWinGoo::win_version; TeXLive::TLWinGoo::is_vista; TeXLive::TLWinGoo::admin; TeXLive::TLWinGoo::non_admin; TeXLive::TLWinGoo::reg_country; TeXLive::TLWinGoo::dir_writable($d); =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::add_texbindir_to_path($texpath); TeXLive::TLWinGoo::remove_texbindirs_from_path; TeXLive::TLWinGoo::register_script_type($extension, $command); TeXLive::TLWinGoo::unregister_script_type($extension); =head2 ACTIVATING CHANGES IMMEDIATELY TeXLive::TLWinGoo::broadcast_env; TeXLive::TLWinGoo::update_assocs; All exported functions return forward slashes. =head2 DESCRIPTION =over 6 =cut BEGIN { use Exporter; use vars qw( @ISA @EXPORT $Registry); @ISA = qw( Exporter ); @EXPORT = qw( &wg_error &win_version &is_vista &admin &non_admin ®_country &dir_writable &expand_string &global_tmpdir &get_system_path &get_user_path &setenv_reg &unsetenv_reg &add_texbindir_to_path &remove_texbindirs_from_path ®ister_script_type &unregister_script_type &broadcast_env &update_assocs ); # for testing also: @EXPORT_OK = qw( &admin_again &get_system_env &get_user_env &win_which_dir &global_tmpdir ); if ($^O=~/^MSWin(32|64)$/i) { #require Win32; #Win32->import( qw( GetOSVersion ) ); 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); } } use TeXLive::TLUtils; my $is_win = $^O=~/^MSWin(32|64)$/i; =pod =back =head2 ERROR HANDLING =over 6 =item C Returns WinGoo error status, in the shape of an array (number, message) and clears the error status. No error <=> error number 0 =cut my $wg_error = 0; my $wg_error_message = ""; sub wg_error { my @retval = ($wg_error, $wg_error_message); $wg_error = 0; $wg_error_message = ""; return @retval; } =pod =back =head2 DIAGNOSTICS =over 6 =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(); } 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 { $is_admin = 0; } # just for testing; doesn't check actual user permissions sub admin_again { $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"}; $value = substr $value, -4; my $lm = $Registry -> Open("HKEY_CLASSES_ROOT/MIME/Database/Rfc1766/", {Access => KEY_READ()})->{"/$value"}; tllog($::LOG_DEBUG, "found lang codes value = $value, lm = $lm...\n"); if ($lm) { return(substr $lm, 0, 2); } } =pod =item C Tests whether its argument is writable by trying to write to it. This function is necessary because the built-in C<-w> test apparently doesn't work under Windows. =cut sub dir_writable { $d=shift; return 0 unless -d $d; $d =~ s!\\!/!g; $d =~ s!/$!!g; my $i = 0; while (-e $d . "/" . $i) { $i++; } my $f = $d."/".$i; my $fb = $f; $fb =~ s!/!\\!g; return 0 if system('copy /b ' . $ENV{'COMSPEC'} . ' "' . $fb . '" >nul 2>&1'); unlink $f if -e $f; return 1; } =pod =back =head2 ENVIRONMENT AND REGISTRY =over 6 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. =item C This function replaces substrings C<%env_var%> with their current values as environment variable and returns the result. =cut sub expand_string { $s = shift @_; while ($s =~ /^([^%]*)%([^%]+)%(.*)$/) { foreach $k (keys %ENV) { if (uc($k) eq uc($2)) { $s = $1 . $ENV{$k} . $3; last; } } } $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; #my $xd = expand_string($d); $d =~ s/\\/\//g; $d =~ s/\/$//; my $d1 = $d . '/pdftex.exe'; my $d2 = $d . '/tex.exe'; return ((-e $d1) or (-e $d2)); } =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'}; $value =~ s/\\/\//g; # 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/\\/\//g; $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; 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" 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") { my $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" 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 Remove wrong TeX directories from system path (if possible) and user path. A directory is a TeX directory if it contains tex.exe or pdftex.exe. Then if necessary add desired TeX directory; to system path if admin, otherwise to user path. wg_error gets set if there is a connflicting tex directory which cannot be removed from the path. =cut sub add_texbindir_to_path { $wg_error = 0; # clear error status my $texbindir = shift; my $system_env = get_system_env(); my $user_env = get_user_env(); my $d; my $d_exp; my $found = 0; my @newpt; my $newp; # system path if ($is_admin) { @newpt = (); foreach $d (split (';', get_system_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; if (uc($d_exp) eq uc($texbindir)) { push @newpt, $d unless $found; $found = 1; } elsif (!is_a_texdir($d_exp)) { push @newpt, $d; } } push @newpt, $texbindir unless $found; $found = 1; $newp = join (';', @newpt); $newp =~ s/\//\\/g; setenv_reg("Path", $newp, "system"); #$system_env->ArrayValues(1); # use value_data, value_type pairs #$system_env -> {"/Path"} = [ $newp, REG_EXPAND_SZ ]; } else { # non-admin # system path foreach $d (split (';', get_system_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; if (uc($d_exp) eq uc($texbindir)) { $found = 1; } elsif (is_a_texdir($d_exp)) { $wg_error = 1; $wg_error_message = "Warning: possibly conflicting [pdf]TeX program found at $d_exp\n"; tllog($::LOG_DEBUG, $wg_error_message); } } } # user path @newpt = (); foreach $d (split (';', get_user_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; if (uc($d_exp) eq uc($texbindir)) { push @newpt, $d unless $found; # admin case: always $found $found = 1; } elsif (!is_a_texdir($d_exp)) { push @newpt, $d; } } push @newpt, $texbindir unless $found; if (@newpt) { $newp = join ';', @newpt; $newp =~ s/\//\\/g; $user_env->ArrayValues(1); # use value_data, value_type pairs #$user_env -> {"/Path"} = [ $newp, # ($newp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; setenv_reg("Path", $newp, "user"); } else { unsetenv_reg("PAth", "user"); } } =pod =item C Remove all directories from the searchpath which contain tex.exe or pdftex.exe. Do this with the user path and if admin also with the system path. =cut sub remove_texbindirs_from_path { $wg_error = 0; # clear error status my $system_env = get_system_env(); my $user_env = get_user_env(); my ($d, $d_exp, @newpt, $newp); # system path if ($is_admin) { @newpt = (); foreach $d (split (';', get_system_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; push @newpt, $d unless is_a_texdir($d_exp); } $newp = join (';', @newpt); $newp =~ s/\//\\/g; setenv_reg("Path", $newp, "system"); } # user path @newpt = (); foreach $d (split (';', get_user_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; push @newpt, $d unless is_a_texdir($d_exp); } if (@newpt) { $newp = join(';', @newpt); $newp =~ s/\//\\/g; setenv_reg("Path", $newp, "user"); } else { unsetenv_reg("Path", "user"); } } # delete a registry key recursively. # the key parameter should be a string, not a registry object. # We shall use this with file types. sub reg_delete_recurse { my $parent = shift; my $childname = shift; tllog ($::LOG_DDDEBUG, "Deleting $childname regkey\n"); if ($childname !~ '^/') { # subkey my $child = $parent->Open ($childname, {Access => KEY_ALL_ACCESS()}); foreach my $v (keys %$child) { if ($v =~ '^/') { # value delete $child->{$v}; } else { # subkey reg_delete_recurse ($child, $v); } } delete $child->{'/'}; } delete $parent->{$childname}; } =pod =pod =item C Add registry entries to associate $extension with $command and make $extension an executable file type. Slashes are flipped where necessary. =cut sub register_script_type { my $extension = shift; $extension = '.'.$extension unless $extension =~ /^\./; # ensure leading dot $extension = uc($extension); my $command = shift; $command =~s/\//\\/g; tllog ($::LOG_DDEBUG, "Linking $extension to $command\n"); my $user_env = get_user_env(); my $system_env = get_system_env(); my ($pathext, $found, $e, $classes_key, $k); # pathext if ($is_admin) { # system pathext $pathext = $system_env -> {'/PATHEXT'}; $found = 0; foreach $e (split(/;/,$pathext)) { $found = 1 if (uc($e) eq $extension); } setenv_reg("PATHEXT", $pathext.";".$extension, "system") unless $found; # user pathext $pathext = $user_env -> {'/PATHEXT'}; if ($pathext) { $found = 0; foreach $e (split(/;/,$pathext)) { $found = 1 if (uc($e) eq $extension); } setenv_reg("PATHEXT", $pathext.";".$extension, "user") unless $found; } } else { # non-admin $pathext = $user_env -> {'/PATHEXT'}; $pathext = $system_env -> {'/PATHEXT'} if not $pathext; $found = 0; foreach $e (split(/;/,$pathext)) { $found = 1 if (uc($e) eq $extension); } setenv_reg("PATHEXT", $pathext.";".$extension, "user") unless $found; } # file type $extension = lc($extension); if ($is_admin) { $classes_key = $Registry -> Open("LMachine/Software/Classes/", {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath"; $k = $classes_key->CreateKey($extension); $k -> ArrayValues(0); $k -> {"/"} = "script".$extension; $k = $classes_key->CreateKey("script".$extension."/Shell/Open/Command/"); $k -> ArrayValues(1); $k -> {"/"} = [ '"'.$command.'" "%1" %*', ($command =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; # delete possibly conflicting values from HKCU/software $classes_key = $Registry -> Open("CUser/Software/Classes/", {Access => KEY_ALL_ACCESS()}); delete $classes_key -> {$extension}; reg_delete_recurse($classes_key, "script".$extension); } else { $classes_key = $Registry -> Open("CUser/Software/Classes/", {Access => KEY_ALL_ACCESS()}); $k = $classes_key->CreateKey($extension); $k -> ArrayValues(0); $k -> {"/"} = "script".$extension; $k = $classes_key->CreateKey("script".$extension."/Shell/Open/Command/"); $k -> ArrayValues(1); $k -> {"/"} = [ '"'.$command.'" "%1" %*', ($command =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; } } =pod =item C Reversal of register_script_type. =cut sub unregister_script_type { # we don't error check; we just do the best we can. my $extension = shift; $extension = '.'.$extension unless $extension =~ /^\./; # ensure leading dot $extension = uc($extension); tllog ($::LOG_DDEBUG, "unregistering $extension\n"); my $user_env = get_user_env(); my $system_env = get_system_env(); my ($pathext, @newpe, $newpex, $e); # pathext tllog ($::LOG_DDEBUG, "Reverting PATHEXT\n"); if ($is_admin) { $pathext = $system_env -> {'/PATHEXT'}; @newpe = (); foreach $e (split(/;/,$pathext)) { push @newpe, $e unless (uc($e) eq $extension); } $newpex = join(";",@newpe); setenv_reg("PATHEXT", $newpex, "system"); $pathext = $user_env -> {'/PATHEXT'}; if ($pathext) { @newpe = (); foreach $e (split(/;/,$pathext)) { push @newpe, $e unless (uc($e) eq $extension); } $newpex = join(";",@newpe); if ($newpex eq ($system_env -> {"/PATHEXT"})) { unsetenv_reg("PATHEXT", "user"); } else { setenv_reg("PATHEXT", $newpex, "user"); } } } else { $pathext = $user_env -> {'/PATHEXT'}; $pathext = $system_env -> {'/PATHEXT'} unless $pathext; @newpe = (); foreach $e (split(/;/,$pathext)) { push @newpe, $e unless (uc($e) eq $extension); } $newpex = join(";",@newpe); if ($newpex eq ($system_env -> {"/PATHEXT"})) { unsetenv_reg("PATHEXT", "user"); } else { setenv_reg("PATHEXT", $newpex, "user"); } } # file type tllog ($::LOG_DDEBUG, "Deleting texlua filetype\n"); $extension = lc($extension); my $classes_key = $Registry -> Open("CUser/Software/Classes/", {Access => KEY_ALL_ACCESS()}); if ($classes_key) { reg_delete_recurse ($classes_key, $extension."/"); reg_delete_recurse ($classes_key, "script".$extension."/"); } else { tllog ($::LOG_DDEBUG, "Cannot open HKCU classes for write\n"); } if ($is_admin) { $classes_key = $Registry -> Open("LMachine/Software/Classes/", {Access => KEY_ALL_ACCESS()}); if ($classes_key) { reg_delete_recurse ($classes_key, $extension."/"); reg_delete_recurse ($classes_key, "script".$extension."/"); } else { tllog ($::LOG_DDEBUG, "Cannot open HKLM classes for write\n"); } reg_delete_recurse ($classes_key, "script$extension"); } } =pod =back =head2 ACTIVATING CHANGES IMMEDIATELY =over 6 =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; $wg_error = 0; tllog($::LOG_DDEBUG, "Broadcasting \"Enviroment settings changed\" message...\n"); $SendMessage = new Win32::API('user32', 'SendMessage', 'LLPP', 'L'); $result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 'Environment') if $SendMessage; tllog ($::LOG_DDEBUG, "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) { tllog ($::LOG_DDEBUG, "Notifying changes in filetypes...\n"); $update_fu->Call (SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0); tllog ($::LOG_DDEBUG, "Done notifying\n"); } else { tllog ($::LOG_DDEBUG, "No update_fu\n"); } } =pod =back =cut # needs a terminal 1 for require to succeed! 1; __END__