path: root/Master/tlpkg/TeXLive/TLWinGoo.pm

# 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<TeXLive::TLWinGoo> -- Additional utilities for Windows

=head2 SYNOPSIS

  use TeXLive::TLWinGoo;

  TeXLive::TLWinGoo::wg_error;
  TeXLive::TLWinGoo::admin;
  TeXLive::TLWinGoo::non_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;
  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
    &admin
    &non_admin
    &reg_country
    &dir_writable
    &expand_string
    &global_tmpdir
    &get_system_path
    &get_user_path
    &add_texbindir_to_path
    &remove_texbindirs_from_path
    &register_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::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<wg_error>

Returns WinGoo error status, in the shape of an array (number,
message) and clears the error status. No error <=> error number 0

=cut

sub wg_error {
  my @retval = ($wg_error, $wg_error_message);
  $wg_error = 0;
  $wg_error_message = "";
  return @retval;
}

=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>

Renounce 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<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"};
  $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<dir_writable>

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

=item C<expand_string>

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<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;
}

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<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'};
  $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<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/\\/\//g;
  $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;
  foreach $d (split (';',$path)) {
    $d =~ s/\/$//;
    return $d if -e $d.'/'.$prog;
  }
  return 0;
}

#=pod
#
#=item C<add_to_path>
#
#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<add_texbindir_to_path>

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;
    $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 ];
  } else {
    delete $user_env -> {'/Path'};
  }
}

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;
    $system_env->ArrayValues(1); # use value_data, value_type pairs
    $system_env -> {"/Path"} = [ $newp, REG_EXPAND_SZ ];
  }

  # 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;
    $user_env->ArrayValues(1); # use value_data, value_type pairs
    $user_env -> {"/Path"} = [ $newp,
      ($newp =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
  } else {
    delete $user_env -> {"/Path"};
  }
}

# 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

=item C<register_script_type>

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);

  # pathext
  if ($is_admin) {
    # system pathext
    $pathext = $system_env -> {'/PATHEXT'};
    $found = 0;
    foreach $e (split(/;/,$pathext)) {
      $found = 1 if (uc($e) eq $extension);
    }
    $system_env -> {'/PATHEXT'} = $pathext.";".$extension unless $found;
    # user pathext
    $pathext = $user_env -> {'/PATHEXT'};
    if ($pathext) {
      $found = 0;
      foreach $e (split(/;/,$pathext)) {
        $found = 1 if (uc($e) eq $extension);
      }
      $user_env -> {'/PATHEXT'} = $pathext.";".$extension 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);
    }
    $user_env -> {"/PATHEXT"} = $pathext.";".$extension 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";
    $classes_key->ArrayValues(0);
    $classes_key->CreateKey($extension)->SetValue("","script".$extension);
    $classes_key->CreateKey("script".$extension."/Shell/Open/Command/")->
      SetValue("", '"'.$command.'" "%1" %*');
    # 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()});
    $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<unregister_script_type>

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);
    $system_env -> {"/PATHEXT"} = $newpex;

    $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"})) {
        delete $user_env->{"/PATHEXT"};
      } else {
        $user_env -> {"/PATHEXT"} = $newpex;
      }
    }
  } 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"})) {
      delete $user_env->{"/PATHEXT"};
    } else {
      $user_env -> {"/PATHEXT"} = $newpex;
    }
  }

  # 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

=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;
  $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<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) {
    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__