# 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; TeXLive::TLWinGoo::wg_error; TeXLive::TLWinGoo::admin; TeXLive::TLWinGoo::reg_country; TeXLive::TLWinGoo::dir_writable($d); TeXLive::TLWinGoo::expand_string($s); TeXLive::TLWinGoo::global_tmpdir; TeXLive::TLWinGoo::get_system_path; TeXLive::TLWinGoo::get_user_path; TeXLive::TLWinGoo::add_texbindir_to_path($texpath); TeXLive::TLWinGoo::register_script_type($extension, $command); TeXLive::TLWinGoo::unregister_script_type($extension); TeXLive::TLWinGoo::broadcast_env; 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 &admin ®_country &dir_writable &expand_string &global_tmpdir &get_system_path &get_user_path &add_texbindir_to_path ®ister_script_type &unregister_script_type &broadcast_env ); 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); } } use TeXLive::TLUtils; ######################################### # Variables storing status information. # error status stored in wg_errno and wg_errmess my $wg_error = 0; my $wg_error_message = ""; my $is_win = $^O=~/^MSWin(32|64)$/i; # Under Windows, the variables below are calculated while loading this module. # The functions &admin and &global_tmpdir simply return these variables. my $is_admin = 1; my $global_tmp = "/tmp"; # permissions with which we try to access the system environment 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()}); } # error handling =pod =item C Returns WinGoo error status, in the shape of an array (number, message) and clears the error status. No error <=> error numer 0 =cut sub wg_error { my @retval = ($wg_error, $wg_error_message); $wg_error = 0; $wg_error_message = ""; return @retval; } =pod =item C Our test for being an administrator is the ability to change the system environment. It would be nice to have an install/menu option to set admin to false in case the user wants to install just for himself. =cut sub admin { return $is_admin; } =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; #print $f."\n"; return 0 unless open TEST, ">".$f; my $written = 0; $written = (print TEST "\n"); close TEST; unlink $f; return $written; } =pod =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; } 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 not used. # #=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 # #Returns its arguments joined with C<;> as separator, or returns the second #argument if the first is an empty string. # #=cut sub add_to_path { my $old_path = shift @_; my $addition = shift @_; return ($old_path eq "") ? $addition : $old_path . ";" . $addition; } =pod =item C Remove any 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 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 $texbindir = shift; my $syspath_temp = ""; my $d_exp; foreach $d (split (';', get_system_path())) { $d_exp = expand_string($d); $d_exp =~ s/\\/\//g; $d_exp =~ s/\/$//; if (is_a_texdir($d_exp)) { if (!$is_admin and (uc($d_exp) ne uc($texbindir))) { $wg_error = 1; $wg_error_message = "Warning: possibly conflicting [pdf]TeX program found at $d_exp\n"; } } elsif ($is_admin) { $syspath_temp = add_to_path($syspath_temp, $d); } } if ($is_admin) { $syspath_temp = add_to_path($syspath_temp, $texbindir); $syspath_temp =~ s/\//\\/g; my $system_env = get_system_env(); $system_env->ArrayValues(1); # use value_data, value_type pairs $system_env -> {"/Path"} = [ $syspath_temp, REG_EXPAND_SZ ]; } # fix user path # admin: remove any texdir but don't add anything # user: remove any texdir and append new texdir my $userpath_temp = ""; foreach $d (split (';', get_user_path())) { $d_exp = expand_string($d); $userpath_temp = add_to_path($userpath_temp, $d) if (not is_a_texdir($d_exp)); } $userpath_temp = add_to_path($userpath_temp, $texbindir) if !$is_admin; if ($userpath_temp) { $userpath_temp =~ s/\//\\/g; my $user_env = get_user_env(); $user_env->ArrayValues(1); # use value_data, value_type pairs $user_env -> {"/Path"} = [ $userpath_temp, ($userpath_temp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; } else { delete $user_env -> {'Path'}; } } =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; # pathext my $pathext = get_user_env() -> {'/PATHEXT'}; $pathext = get_system_env() -> {'/PATHEXT'} if not $pathext; my $found = 0; foreach my $e (split(/;/,$pathext)) { $found = 1 if (uc($e) eq $extension); } if (!$found) { if ($is_admin) { (get_system_env() -> {"/PATHEXT"}) = $pathext.";".$extension; } else { (get_user_env() -> {"/PATHEXT"}) = $pathext.";".$extension; } } # file type $extension = lc($extension); my $classes_key = $Registry -> Open( ($is_admin ? "LMachine/Software/Classes/" : "CUser/Software/Classes/"), {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath"; $classes_key->ArrayValues(0); $classes_key->CreateKey($extension)->SetValue("","script".$extension); $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")-> SetValue("", '"'.$command.'" "%1" %*'); } =pod =item C Reversal of register_script_type. =cut sub unregister_script_type { my $extension = shift; $extension = '.'.$extension unless $extension =~ /^\./; # ensure leading dot $extension = uc($extension); # pathext my $pathext = get_user_env() -> {'/PATHEXT'}; $pathext = get_system_env() -> {'/PATHEXT'} if not $pathext; my @newpe; foreach my $e (split(/;/,$pathext)) { push @newpe, $e unless (uc($e) eq $extension); } my $newpe = join(";",@newpe); if ($is_admin) { (get_system_env() -> {"/PATHEXT"}) = $newpe; } else { (get_user_env() -> {"/PATHEXT"}) = $newpe; } # file type $extension = lc($extension); my $classes_key = $Registry -> Open( ($is_admin ? "LMachine/Software/Classes/" : "CUser/Software/Classes/"), {Access => KEY_ALL_ACCESS()}) or die "Cannot open classpath"; delete $classes_key{$extension}; delete $classes_key{"script$extension"}; # $classes_key->CreateKey($extension)->SetValue("","script".$extension); # $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")-> # SetValue("", $command.' "%1" %*'); } =pod =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 @proto = ('SendMessage', 'LLPP', 'L'); my $result = ""; my $SendMessage; $wg_error = 0; print "Broadcasting \"Enviroment settings changed\" message...\n"; $SendMessage = new Win32::API('user32', @proto); $result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 'Environment') if $SendMessage; print "Broadcast complete; result: $result.\n"; } =pod =back =cut # needs a terminal 1 for require to succeed! 1; __END__ ### Local Variables: ### perl-indent-level: 2 ### tab-width: 2 ### indent-tabs-mode: nil ### End: # vim:set tabstop=2 expandtab: #