summaryrefslogtreecommitdiff
path: root/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm')
-rw-r--r--Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm1286
1 files changed, 0 insertions, 1286 deletions
diff --git a/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm b/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm
deleted file mode 100644
index bd15e2d517f..00000000000
--- a/Master/tlpkg/dev/tlwingoonew/TLWinGoo.pm
+++ /dev/null
@@ -1,1286 +0,0 @@
-# $Id: TLWinGoo.pm 19264 2010-07-07 00:06:03Z trzeciak $
-# TeXLive::TLWinGoo.pm - Windows nastiness
-# Copyright 2008, 2009, 2010, 2011 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: 19264 $';
-my $_modulerevision;
-if ($svnrev =~ m/: ([0-9]+) /) {
- $_modulerevision = $1;
-} else {
- $_modulerevision = "unknown";
-}
-sub module_revision {
- return $_modulerevision;
-}
-
-=pod
-
-=head1 NAME
-
-C<TeXLive::TLWinGoo> -- Additional utilities for Windows
-
-=head2 SYNOPSIS
-
- use TeXLive::TLWinGoo;
-
-=head2 DIAGNOSTICS
-
- TeXLive::TLWinGoo::win_version;
- TeXLive::TLWinGoo::is_vista;
- TeXLive::TLWinGoo::admin;
- TeXLive::TLWinGoo::non_admin;
- TeXLive::TLWinGoo::reg_country;
-
-=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::adjust_reg_path_for_texlive($action, $texbindir, $mode);
- 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);
- TeXLive::TLWinGoo::register_application($prog, $path, $exts);
- TeXLive::TLWinGoo::unregister_application($prog);
- TeXLive::TLWinGoo::add_to_openwithlist($ext, $prog);
- TeXLive::TLWinGoo::remove_from_openwithlist($ext, $prog);
-
-=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;
-
-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(
- &win_version
- &is_vista
- &admin
- &non_admin
- &reg_country
- &expand_string
- &global_tmpdir
- &get_system_path
- &get_user_path
- &setenv_reg
- &unsetenv_reg
- &adjust_reg_path_for_texlive
- &register_extension
- &unregister_extension
- &register_file_type
- &unregister_file_type
- &register_application
- &unregister_application
- &add_to_openwithlist
- &remove_from_openwithlist
- &broadcast_env
- &update_assocs
- &shell_folder
- &desktop_path
- &add_desktop_shortcut
- &add_menu_shortcut
- &remove_desktop_shortcut
- &remove_menu_shortcut
- &create_uninstaller
- &unregister_uninstaller
- );
- # for testing also:
- @EXPORT_OK = qw(
- &admin_again
- &get_system_env
- &get_user_env
- &global_tmpdir
- &is_a_texdir
- &tex_dirs_on_path
- );
- 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);
- require Win32::Shortcut;
- Win32::Shortcut->import( qw( SW_SHOWNORMAL SW_SHOWMINNOACTIVE ) );
- }
-}
-
-use TeXLive::TLConfig;
-use TeXLive::TLUtils;
-TeXLive::TLUtils->import( qw( mkdirhier ) );
-
-my $is_win = $^O=~/^MSWin(32|64)$/i;
-
-=pod
-
-=back
-
-=head2 DIAGNOSTICS
-
-=over 4
-
-=item C<win_version>
-
-C<win_version> 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<is_vista>
-
-C<is_vista> 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();
- debug("Configuring TLWinGoo for " .
- ($is_admin ? "admin" : "user") . "mode\n") if win32();
-}
-
-sub get_user_env {
- return $Registry -> Open("CUser/Environment", {Access => KEY_ALL_ACCESS()});
-}
-
-=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>
-
-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<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"};
- return 0 unless $value;
- # there might be trailing nulls on Vista
- $value =~ s/\x00*$//;
- $value = substr $value, -4;
- return 0 unless $value;
- my $lmkey = $Registry -> Open("HKEY_CLASSES_ROOT/MIME/Database/Rfc1766/",
- {Access => KEY_READ()});
- return 0 unless $lmkey;
- $lm = $lmkey->{"/$value"};
- return 0 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 {
- return(substr $lm, 0, 2);
- }
- }
-}
-
-=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<expand_string($s)>
-
-This function replaces substrings C<%env_var%> with their current
-values as environment variable and returns the result.
-
-=cut
-
-sub expand_string {
- my ($s) = @_;
- $s =~ s/%([^%;]+)%/$ENV{$1} ? $ENV{$1} : "%$1%"/eg;
- return $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;
-}
-
-my $global_tmp = "/tmp";
-
-sub global_tmpdir { return $global_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<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'};
- # 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/[\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;
-# $path =~ s/\\/\//g;
-# foreach $d (split (';',$path)) {
-# $d =~ s/\/$//;
-# return $d if -e $d.'/'.$prog;
-# }
-# return 0;
-#}
-
-=pod
-
-=item C<setenv_reg($env_var, $env_data[, $mode]);>
-
-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<unsetenv_reg($env_var[, $mode]);>
-
-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<tex_dirs_on_path($path)>
-
-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<adjust_reg_path_for_texlive($action, $tlbindir, $mode)>
-
-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
-
-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: compar $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;
-}
-
-### helper subs for file types ###
-
-# delete a registry key recursively.
-# the key parameter should be a string, not a registry object.
-
-sub getans {
- my $prompt = shift;
- my $ans;
- print STDERR "$prompt\n";
- $ans = <STDIN>;
- if ($ans =~ /^y/i) {return 1;}
- die "Aborting as requested";
-}
-
-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_ALL_ACCESS()});
- return unless $child;
- foreach my $v (keys %$child) {
- if ($v =~ '^/') { # value
- delete $child->{$v};
- } else { # subkey
- reg_delete_recurse ($child, $v);
- }
- }
- delete $child->{'/'};
- }
- delete $parent->{$childname};
-}
-
-sub cu_root {
- my $k = $Registry -> Open("CUser", {
- Access => KEY_ALL_ACCESS(), Delimiter => '/'
- });
- die "Cannot open HKCU for writing" unless $k;
- return $k;
-}
-
-sub lm_root {
- my $k = $Registry -> Open("LMachine", {
- Access => ($is_admin ? KEY_ALL_ACCESS() : KEY_READ()),
- Delimiter => '/'
- });
- die "Cannot open HKLM for ".($is_admin ? "writing" : "reading")
- unless $k;
- return $k;
-}
-
-# write a registry key or not, depending on
-# mode, existing keys and privilege level
-
-sub do_write_regkey {
- my $mode = shift;
- my $keypath = shift; # modulo cu/lm
- my $keyhash = shift; # ref to a possibly nested hash
- die "No regkey specified" unless $keypath && defined($keyhash);
- # for error reporting:
- my $hivename = $is_admin ? 'HKLM' : 'HKCU';
-
- if ($mode == 0) {
- ddebug "Mode 0: not writing $hivename/$keypath key\n";
- return 1;
- }
-
- # 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 $do_create = 1;
- if ($mode == 1) {
- if ($is_admin) {
- if ($lm_key->{$keypath}) {
- $do_create = 0;
- debug "Not writing HKLM/$keypath because already present\n";
- }
- } else {
- if ($cu_key->{$keypath}) {
- $do_create = 0;
- debug "Not writing HKCU/$keypath because already present\n";
- } elsif ($lm_key->{$keypath}) {
- $do_create = 0;
- debug "Not writing HKCU/$keypath because ".
- "HKLM/$keypath already present\n";
- }
- }
- };
- return 1 unless $do_create;
- my $parentkey;
- if ($is_admin) {
- $parentkey = $lm_key->Open($parentpath);
- if (!$parentkey) {
- # in most cases, this probably shouldn't happen for lm
- $parentkey = $lm_key->CreateKey($parentpath);
- }
- } else {
- $parentkey = $cu_key->Open($parentpath);
- if (!$parentkey) {
- $parentkey = $cu_key->CreateKey($parentpath);
- }
- }
- if (!$parentkey) {
- tlwarn "Cannot create parent of $hivename/$keypath\n";
- return 0;
- }
- if ($parentkey->{$keyname}) {reg_delete_recurse($parentkey, $keyname);}
- $parentkey->{$keyname} = $keyhash;
- if (!$parentkey->{$keyname}) {
- tlwarn "Failure to create HKLM/$keypath\n";
- return 0;
- }
- if ($is_admin and $cu_key->{$keypath}) {
- # delete possibly conflicting cu key
- reg_delete_recurse ($cu_key->{$parentpath}, $keyname);
- }
- if (!$parentkey) {
- $parentkey = $cu_key->CreateKey($parentpath);
- if (!$parentkey) {
- tlwarn "Cannot create parentpath of HKCU/$keypath\n";
- return 0;
- }
- }
- if ($parentkey->{$keyname}) {reg_delete_recurse($parentkey, $keyname);}
- $parentkey->{$keyname} = $keyhash;
- if (!$parentkey->{$keyname}) {
- tlwarn "Failure to create $hivename/$keypath\n";
- return 0;
- }
- return 1;
-}
-
-sub do_remove_regkey {
- my $mode = shift;
- my $keypath = shift;
- my $testhash = shift;
- # hashref of subkey/value => data pairs
- # mode 1: if any is present and does not match, then do not remove
- # ATM we assume REG_SZ data
- # In future, a we might use a subroutine reference instead.
- my $hivename = $is_admin ? 'HKLM' : 'HKCU';
-
- if ($mode == 0) {
- ddebug "Mode 0: not removing $hivename/$keypath key\n";
- return 1;
- }
-
- my ($parentpath, $keyname);
- if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) {
- ($parentpath, $keyname) = ($1, $2);
- $keyname .= '/';
- } else {
- die "Cannot determine final component of $keypath";
- }
-
- my $cu_key = cu_root();
- my $lm_key = lm_root();
- if ($is_admin) {
- return 0 unless $lm_key;
- } else {
- return 0 unless $cu_key;
- }
- my $do_remove = 1;
- my ($parentkey, $k, $skv, $d);
- if ($is_admin) {
- $parentkey = $lm_key->Open($parentpath);
- } else {
- $parentkey = $cu_key->Open($parentpath);
- }
- if (!$parentkey) {
- $do_remove = 0;
- tlwarn "Unable to open $roothive/$parentpath for writing\n";
- return 0;
- }
- if ($mode == 1) {
- $k = $parentkey->{$keyname};
- if ($k) {
- if ($testhash) {foreach $skv (keys %$testhash) {
- $d = $k->{$keyname.$skv};
- if ($d and $d ne $test->{$skv}) {
- $do_remove = 0;
- debug "$hivename/$keypath modified; not deleting\n";
- last;
- }
- }}
- } else {
- $do_remove = 0;
- debug "$hivename/$keypath not present or not writable so not removed\n";
- }
- };
- return 1 unless $do_remove;
- #getans("Deleting $parentpath$keyname regkey? ");
- reg_delete_recurse($parentkey, $keyname);
- if ($parentkey->{$keyname}) {
- tlwarn "Failure to delete $roothive/$keypath\n";
- return 0;
- }
- if ($is_admin and $cu_key->{$parentpath}) {
- reg_delete_recurse($cu_key->{$parentpath}, $keyname);
- # no errorchecking this once
- }
- return 1;
-}
-
-=pod
-
-=item C<register_extension($mode, $extension, $file_type)>
-
-Add registry entry to associate $extension with $file_type. Slashes
-are flipped where necessary.
-
-If $mode is 0, nothing is actually done. If $mode is 1, only not-present
-keys of keys that are matching the given key are (re)created. If $mode
-is 2 then keys are (re)created in any case.
-
-=cut
-
-sub register_extension {
- my $mode = shift;
- my $extension = shift;
- # ensure leading dot
- $extension = '.'.$extension unless $extension =~ /^\./;
- $extension = lc($extension);
-
- my $file_type = shift;
- debug("Linking $extension to $file_type\n");
-
- my $regkey = {'/' => $file_type};
- do_write_regkey($mode, "Software/Classes/$extension/", $regkey);
-}
-
-=pod
-
-=item C<unregister_extension($mode, $extension, $filetype)>
-
-Reversal of register_extension.
-
-=cut
-
-sub unregister_extension {
- # we don't error check; we just do the best we can.
- my $mode = shift;
- # mode 0: continue anyhow and let do_remove_regkey
- # bail out with a debug message.
- my $extension = shift;
- my $filetype = shift;
- $extension = '.'.$extension unless $extension =~ /^\./;
- debug("unregistering $extension\n");
-
- $testhash = {"/" => $filetype};
- do_remove_regkey($mode, "Software/Classes/".$extension, $testhash);
-}
-
-=pod
-
-=item C<register_file_type($file_type, $command)>
-
-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;
- $command =~s/\//\\/g;
- debug ("Linking $file_type to $command\n");
- my $keyhash = {
- "shell/" => {
- "open/" => {
- "command/" => {
- "/" => $command
- }
- }
- }
- };
- do_write_regkey(2, "Software/Classes/$file_type", $keyhash);
-}
-
-=pod
-
-=item C<unregister_file_type($file_type)>
-
-Reversal of register_script_type.
-
-=cut
-
-sub unregister_file_type {
- # we don't error check; we just do the best we can.
- my $file_type = shift;
- debug ("unregistering $file_type\n");
- do_remove_regkey(2, "Software/Classes/$file_type/");
-}
-
-=pod
-
-=item C<register_application($prog, $path, $exts)>
-
-Add registry entry to set full path of $prog to $path and optionally
-specify which extensions it handles
-
-=cut
-
-sub register_application {
- my $prog = shift; # redundant, but more natural than just $path
- my $path = shift;
- my $exts = shift;
-
- my $hsh;
- foreach my $e (@$exts) {$hsh->{"/$e"} = "";}
- #my $prog = TeXLive::TLUtils::basename($path);
- $cmd = "\"$path\" \"%1\"";
- $cmd =~ s!/!\\!g;
- my $keyhash = {
- "shell/" => {
- "open/" => {
- "command/" => {
- "/" => $cmd
- }
- }
- },
- "SupportedTypes" => $hsh
- };
- do_write_regkey(2, "Software/Classes/Applications/$prog", $keyhash);
-}
-
-=pod
-
-=item C<unregister_application($prog)>
-
-Reversal of register_application
-
-=cut
-
-sub unregister_application {
- my $prog = shift;
- do_remove_regkey(2, "Software/Classes/Applications/$prog/");
-}
-
-=pod
-
-=item C<add_to_openwithlist($ext, $prog)>
-
-Add $prog to the list of programs which open $ext files
-
-=cut
-
-sub add_to_openwithlist {
- my $ext = shift;
- my $prog = shift;
- do_write_regkey(2, "Software/Classes/$ext/OpenWithList/$prog", {});
-}
-
-=pod
-
-=item C<remove_from_openwithlist($ext, $prog)>
-
-Remove $prog from the list of programs which open $ext files
-
-=cut
-
-sub remove_from_openwithlist {
- my $ext = shift;
- my $prog = shift;
- do_remove_regkey(2, "Software/Classes/$ext/OpenWithList/$prog");
-}
-
-=pod
-
-=back
-
-=head2 ACTIVATING CHANGES IMMEDIATELY
-
-=over 4
-
-=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;
- 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");
-}
-
-=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) {
- 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
-
-=cut
-
-# short path names
-
-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<shell_folder>
-
-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_desktop_shortcut($name, $icon, $prog, $args, $batgui)>
-
-Add a desktop 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.
-
-=cut
-
-sub add_desktop_shortcut {
- my ($name, $icon, $prog, $args, $batgui) = @_;
-
- # create shortcut
- 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->Save($shfile);
-}
-
-=pod
-
-=item C<add_menu_shortcut($place, $name, $icon,
- $prog, $args, $batgui)>
-
-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.
-
-=cut
-
-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)) {
- next; # fail silently and don't worry about it
- } elsif (not (-d $shpath)) {
- mkdirhier($shpath);
- return unless -d $shpath;
- }
- $shfile = $shpath.'/'.$name.'.lnk';
- $shc->Save($shfile);
-}
-
-=pod
-
-=item C<remove_desktop_shortcut($name)>
-
-For uninstallation of an individual package.
-
-=cut
-
-sub remove_desktop_shortcut {
- my $name = shift;
- unlink desktop_path().'/'.$name.'.lnk';
-}
-
-=pod
-
-=item C<remove_menu_shortcut($place, $name)>
-
-For uninstallation of an individual package.
-
-=cut
-
-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<create_uninstaller>
-
-Writes registry entries for add/remove programs which reference
-the uninstaller script and creates uninstaller batchfiles to finish
-the job.
-
-=cut
-
-sub create_uninstaller {
- my ($tdfw, $tdwfw, $tdsvfw, $tdscfw) = @_;
- # TEXDIR, TEXDIRW, TEXMFSYSVAR, TEXMFSYSCONFIG
- $tdfw =~ s![\\/]$!!;
- my $td = $tdfw;
- $td =~ s!/!\\!g;
-
- $tdwfw =~ s![\\/]$!!;
- my $tdw = $tdwfw;
- $tdw =~ s!/!\\!g;
-
- $tdsvfw =~ s![\\/]$!!;
- my $tdsv = $tdsvfw;
- $tdsv =~ s!/!\\!g;
-
- $tdscfw =~ s![\\/]$!!;
- my $tdsc = $tdscfw;
- $tdsc =~ s!/!\\!g;
-
- my $uninst_key = $Registry -> Open((admin() ? "LMachine" : "CUser") .
- "/software/microsoft/windows/currentversion/",
- {Access => KEY_ALL_ACCESS()});
- my $k = $uninst_key->CreateKey(
- "uninstall/TeXLive$::TeXLive::TLConfig::ReleaseYear/");
- $k->{"/DisplayName"} = "TeX Live $::TeXLive::TLConfig::ReleaseYear";
- $k->{"/UninstallString"} = "\"$tdw\\tlpkg\\installer\\uninst.bat\"";
- $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear;
- $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive";
-
- mkdirhier("$tdwfw/tlpkg/installer"); # wasn't this done yet?
- if (open UNINST, ">$tdwfw/tlpkg/installer/uninst.bat") {
- print UNINST <<UNEND;
-\@echo off
-setlocal
-rem This should not be necessary, but sometimes it is:
-path $td\\tlpkg\\tlperl\\bin;$td\\bin\\win32;%path%
-set PERL5LIB=$td\\tlpkg\\tlperl\\lib
-perl.exe \"$td\\texmf\\scripts\\texlive\\uninstall-win32.pl\"
-if errorlevel 1 goto :eof
-copy \"$tdw\\tlpkg\\installer\\uninst2.bat\" \"\%TEMP\%\"
-rem pause
-\"\%TEMP\%\\uninst2.bat\"
-UNEND
-;
- close UNINST;
- } else {
- warn "Cannot open $tdwfw/tlpkg/installer/uninst.bat for append";
- }
-
- if (open UNINST2, ">$tdwfw/tlpkg/installer/uninst2.bat") {
- print UNINST2 <<UNEND2 if ($td eq $tdw);
-rmdir /s /q \"$td\\texmf-dist\"
-rmdir /s /q \"$td\\texmf-doc\"
-rmdir /s /q \"$td\\texmf\"
-rmdir /s /q \"$td\\readme-html.dir\"
-rmdir /s /q \"$td\\readme-txt.dir\"
-rmdir /s /q \"$td\\bin\"
-rmdir /s /q \"$td\\tlpkg\"
-del /q \"$td\\README.*\"
-del /q \"$td\\LICENSE.*\"
-del /q \"$td\\doc.html\"
-del \"$td\\index.html\"
-del \"$td\\texmf.cnf\"
-del \"$td\\install-tl\"
-del \"$td\\tl-portable\"
-del \"$td\\tl-portable.bat\"
-del \"$td\\install-tl.bat\"
-del \"$td\\install-tl-advanced.bat\"
-UNEND2
-;
- print UNINST2 <<UNEND2;
-rmdir /s /q \"$tdsv\"
-rmdir /s /q \"$tdsc\"
-rmdir /s /q \"$tdw\\temp\"
-rmdir /s /q \"$tdw\\tlpkg\"
-del \"$tdw\\install-tl.log\"
-del \"$tdw\\texlive.profile\" 2>nul
-del \"$tdw\\release-texlive.txt\"
-set test=
-for \%\%f in (\"$tdw\\*.*\") do \@set test=nonempty
-if x\%test\%==x rd \"$tdw\"
-\@echo Done uninstalling TeXLive.
-rem \@pause
-del %0
-UNEND2
-;
- close UNINST2;
- } else {
- warn "Cannot open $tdwfw/tlpkg/installer/uninst2.bat for writing";
- }
-}
-
-=pod
-
-=item C<unregister_uninstaller>
-
-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_ALL_ACCESS()});
- reg_delete_recurse($regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/")
- if $regkey_uninst;
-}
-
-=pod
-
-=back
-
-=cut
-
-# 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: #