texlive[47481] Master/tlpkg/installer: Browser dialog for TEXDIR
commits+siepo at tug.org
commits+siepo at tug.org
Sun Apr 29 16:52:02 CEST 2018
Revision: 47481
http://tug.org/svn/texlive?view=revision&revision=47481
Author: siepo
Date: 2018-04-29 16:52:02 +0200 (Sun, 29 Apr 2018)
Log Message:
-----------
Browser dialog for TEXDIR
Modified Paths:
--------------
trunk/Master/tlpkg/installer/install-menu-perltk.pl
trunk/Master/tlpkg/installer/install-menu-wizard.pl
Added Paths:
-----------
trunk/Master/tlpkg/installer/DirSelect.pm
trunk/Master/tlpkg/installer/texdirsel.pl
Added: trunk/Master/tlpkg/installer/DirSelect.pm
===================================================================
--- trunk/Master/tlpkg/installer/DirSelect.pm (rev 0)
+++ trunk/Master/tlpkg/installer/DirSelect.pm 2018-04-29 14:52:02 UTC (rev 47481)
@@ -0,0 +1,503 @@
+#===============================================================================
+# Tk/DirSelect.pm
+# Copyright (C) 2000-2001 Kristi Thompson <kristi at kristi.ca>
+# Copyright (C) 2002-2005,2010 Michael Carman <mjcarman at mchsi.com>
+# Last Modified: 2/16/2010
+#===============================================================================
+BEGIN { require 5.004 }
+
+package Tk::DirSelect;
+use Cwd;
+use File::Spec;
+use Tk 800;
+require Tk::Frame;
+require Tk::BrowseEntry;
+require Tk::Button;
+require Tk::Label;
+require Tk::DirTree;
+
+use strict;
+use base 'Tk::Toplevel';
+Construct Tk::Widget 'DirSelect';
+
+use vars qw'$VERSION';
+$VERSION = '1.12';
+
+my %colors;
+my $isWin32;
+
+#-------------------------------------------------------------------------------
+# Subroutine : ClassInit()
+# Purpose : Class initialzation.
+# Notes :
+#-------------------------------------------------------------------------------
+sub ClassInit {
+ my ($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $isWin32 = $^O eq 'MSWin32';
+
+ # Get system colors from a Text widget for use in DirTree
+ my $t = $mw->Text();
+ foreach my $x (qw'-background -selectbackground -selectforeground') {
+ $colors{$x} = $t->cget($x);
+ }
+ $t->destroy();
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : Populate()
+# Purpose : Create the DirSelect widget
+# Notes :
+#-------------------------------------------------------------------------------
+sub Populate {
+ my ($w, $args) = @_;
+ my $directory = delete $args->{-dir} || cwd();
+ my $title = delete $args->{-title} || 'Select Directory';
+
+ $w->withdraw;
+ $w->SUPER::Populate($args);
+ $w->ConfigSpecs(-title => ['METHOD', 'title', 'Title', $title]);
+ $w->bind('<Escape>', sub { $w->{dir} = undef });
+
+ my %f = (
+ drive => $w->Frame->pack(-anchor => 'n', -fill => 'x'),
+ button => $w->Frame->pack(-side => 'bottom', -anchor => 's', -fill => 'x', -ipady => 6),
+ tree => $w->Frame->pack(-fill => 'both', -expand => 1),
+ );
+
+ $w->{tree} = $f{tree}->Scrolled('DirTree',
+ -scrollbars => 'osoe',
+ -selectmode => 'single',
+ -ignoreinvoke => 0,
+ -width => 50,
+ -height => 15,
+ %colors,
+ %$args,
+ )->pack(-fill => 'both', -expand => 1);
+
+ $w->{tree}->configure(-command => sub { $w->{tree}->opencmd($_[0]) });
+ $w->{tree}->configure(-browsecmd => sub { $w->{tree}->anchorClear });
+
+ $f{button}->Button(
+ -width => 7,
+ -text => 'OK',
+ -command => sub { $w->{dir} = $w->{tree}->selectionGet() },
+ )->pack(-side => 'left', -expand => 1);
+
+ $f{button}->Button(
+ -width => 7,
+ -text => 'Cancel',
+ -command => sub { $w->{dir} = undef },
+ )->pack(-side => 'left', -expand => 1);
+
+ if ($isWin32) {
+ $f{drive}->Label(-text => 'Drive:')->pack(-side => 'left');
+ $w->{drive} = $f{drive}->BrowseEntry(
+ -variable => \$w->{selected_drive},
+ -browsecmd => [\&_browse, $w->{tree}],
+ -state => 'readonly',
+ )->pack(-side => 'left', -fill => 'x', -expand => 1);
+
+ if ($Tk::VERSION >= 804) {
+ # widget is readonly, but shouldn't appear disabled
+ for my $e ($w->{drive}->Subwidget('entry')->Subwidget('entry')) {
+ $e->configure(-disabledforeground => $colors{-foreground});
+ $e->configure(-disabledbackground => $colors{-background});
+ }
+ }
+ }
+ else {
+ $f{drive}->destroy;
+ }
+
+ # right-click context menu
+ my $menu = $w->Menu(
+ -tearoff => 0,
+ -menuitems => [
+ [qw/command ~New/, -command => [\&_mkdir , $w]],
+ [qw/command ~Rename/, -command => [\&_rename, $w]],
+ [qw/command ~Delete/, -command => [\&_rmdir, $w]],
+ ],
+ );
+ $menu->bind('<FocusOut>' => sub {$menu->unpost});
+ $w->{tree}->bind('<Button-3>' => [\&_context, $menu, Ev('X'), Ev('Y')]);
+
+ # popup overlay for renaming directories
+ $w->{renameval} = undef;
+ $w->{popup} = $w->Toplevel();
+ $w->{rename} = $w->{popup}->Entry(
+ -relief => 'groove',
+ -borderwidth => 1,
+ )->pack(-fill => 'x', -expand => 1);
+ $w->{popup}->overrideredirect(1);
+ $w->{popup}->withdraw;
+ $w->{rename}->bind('<Escape>', sub {$w->{renameval} = undef});
+ $w->{rename}->bind('<FocusOut>', sub {$w->{renameval} = undef});
+ $w->{rename}->bind('<KeyPress-Return>', sub {$w->{renameval} = $w->{rename}->get});
+
+ return $w;
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : Show()
+# Purpose : Display the DirSelect widget.
+# Notes :
+#-------------------------------------------------------------------------------
+sub Show {
+ my $w = shift;
+ my $dir = shift;
+ my $cwd = cwd();
+ my $focus = $w->focusSave;
+ my $grab = $w->grabSave;
+
+ $dir = $cwd unless defined $dir && -d $dir;
+ chdir($dir);
+
+ if ($isWin32) {
+ # populate the drive list
+ my @drives = _get_volume_info();
+ $w->{drive}->delete(0, 'end');
+ my $startdrive = _drive($dir);
+
+ foreach my $d (@drives) {
+ $w->{drive}->insert('end', $d);
+ if ($startdrive eq _drive($d)) {
+ $w->{selected_drive} = $d;
+ }
+ }
+ }
+
+ # show initial directory
+ _showdir($w->{tree}, $dir);
+
+ $w->Popup(@_); # show widget
+ $w->focus; # seize focus
+ $w->grab; # seize grab
+ $w->waitVariable(\$w->{dir}); # wait for user selection (or cancel)
+ $w->grabRelease; # release grab
+ $w->withdraw; # run and hide
+ $focus->(); # restore prior focus
+ $grab->(); # restore prior grab
+ chdir($cwd) # restore working directory
+ or warn "Could not chdir() back to '$cwd' [$!]\n";
+
+ # HList SelectionGet() behavior changed around Tk 804.025
+ if (ref $w->{dir} eq 'ARRAY') {
+ $w->{dir} = $w->{dir}[0];
+ }
+
+ {
+ local $^W;
+ $w->{dir} .= '/' if ($isWin32 && $w->{dir} =~ /:$/);
+ }
+
+ return $w->{dir};
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : _browse()
+# Purpose : Browse to a mounted filesystem (Win32)
+# Notes :
+#-------------------------------------------------------------------------------
+sub _browse {
+ my ($w, undef, $d) = @_;
+ $d = _drive($d) . '/';
+ chdir($d);
+ _showdir($w, $d);
+
+ # Workaround: Under Win* versions of Perl/Tk, scrollbars have a tendancy
+ # to show up but be disabled.
+ $w->yview(scroll => 1, 'units');
+ $w->update;
+ $w->yview(scroll => -1, 'units');
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : _showdir()
+# Purpose : Show the requested directory
+# Notes :
+#-------------------------------------------------------------------------------
+sub _showdir {
+ my $w = shift;
+ my $dir = shift;
+ $w->delete('all');
+ $w->chdir($dir);
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : _get_volume_info()
+# Purpose : Get volume information (Win32)
+# Notes :
+#-------------------------------------------------------------------------------
+sub _get_volume_info {
+ require Win32API::File;
+
+ my @drivetype = (
+ 'Unknown',
+ 'No root directory',
+ 'Removable disk drive',
+ 'Fixed disk drive',
+ 'Network drive',
+ 'CD-ROM drive',
+ 'RAM Disk',
+ );
+
+ my @drives;
+ foreach my $ld (Win32API::File::getLogicalDrives()) {
+ my $drive = _drive($ld);
+ my $type = $drivetype[Win32API::File::GetDriveType($drive)];
+ my $label;
+
+ Win32API::File::GetVolumeInformation(
+ $drive, $label, [], [], [], [], [], []);
+
+ push @drives, "$drive [$label] $type";
+ }
+
+ return @drives;
+}
+
+
+#-------------------------------------------------------------------------------
+# Subroutine : _drive()
+# Purpose : Get the drive letter (Win32)
+# Notes :
+#-------------------------------------------------------------------------------
+sub _drive {
+ shift =~ /^(\w:)/;
+ return uc $1;
+}
+
+
+#-------------------------------------------------------------------------------
+# Method : _context
+# Purpose : Display the context menu
+# Notes :
+#-------------------------------------------------------------------------------
+sub _context {
+ my ($w, $m, $x, $y) = @_;
+ my $wy = $y - $w->rooty;
+ $w->selectionClear();
+ $w->selectionSet($w->nearest($wy));
+ $m->post($x, $y);
+ $m->focus;
+}
+
+
+#-------------------------------------------------------------------------------
+# Method : _mkdir
+# Purpose : Create a new directory under the current selection
+# Notes :
+#-------------------------------------------------------------------------------
+sub _mkdir {
+ my $w = shift;
+ my $dt = $w->{tree};
+ my ($sel) = $dt->selectionGet();
+
+ my $cwd = Cwd::cwd();
+ if (chdir($sel)) {
+ my $base = 'NewDirectory';
+ my $name = $base;
+ my $i = 1;
+
+ while (-d $name && $i < 1000) {
+ $name = $base . $i++;
+ }
+
+ unless (-d $name) {
+ if (mkdir($name)) {
+ _showdir($dt, $sel);
+ $dt->selectionClear();
+ $dt->selectionSet($sel . '/' . $name);
+ $w->_rename();
+ }
+ else {
+ $w->messageBox(
+ -title => 'Unable to create directory',
+ -message => "The directory '$name' could not be created.\n$!",
+ -icon => 'error',
+ -type => 'OK',
+ );
+ }
+ }
+
+ chdir($cwd);
+ }
+ else {
+ warn "Unable to chdir() for mkdir() [$!]\n";
+ }
+}
+
+
+#-------------------------------------------------------------------------------
+# Method : _rmdir
+# Purpose : Delete the selected directory
+# Notes :
+#-------------------------------------------------------------------------------
+sub _rmdir {
+ my $w = shift;
+ my $dt = $w->{tree};
+ my ($sel) = $dt->selectionGet();
+
+ my @path = File::Spec->splitdir($sel);
+ my $dir = pop @path;
+ my $pdir = File::Spec->catdir(@path);
+
+ my $cwd = Cwd::cwd();
+ if (chdir($pdir)) {
+ if (rmdir($dir)) {
+ _showdir($dt, $pdir);
+ }
+ else {
+ $w->messageBox(
+ -title => 'Unable to delete directory',
+ -message => "The directory '$dir' could not be deleted.\n$!",
+ -icon => 'error',
+ -type => 'OK',
+ );
+ }
+ chdir($cwd);
+ }
+ else {
+ warn "Unable to chdir() for rmdir() [$!]\n";
+ }
+}
+
+#-------------------------------------------------------------------------------
+# Method : _rename
+# Purpose : Rename the selected directory
+# Notes :
+#-------------------------------------------------------------------------------
+sub _rename {
+ my $w = shift;
+ my $dt = $w->{tree};
+ my $popup = $w->{popup};
+ my $entry = $w->{rename};
+ my ($sel) = $dt->selectionGet();
+ my ($x, $y, $x1, $y1) = $dt->infoBbox($sel);
+
+ my @path = File::Spec->splitdir($sel);
+ my $dir = pop @path;
+ my $pdir = File::Spec->catdir(@path);
+
+ $entry->delete(0, 'end');
+ $entry->insert(0, $dir);
+ $entry->selectionRange(0, 'end');
+ $entry->focus;
+
+ my $font = ($entry->configure(-font))[4];
+ my $text = 'ABCDEFGHIGKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 ';
+ my $width = $entry->fontMeasure($font, $text) / length($text);
+ $entry->configure(-width => ($x1 - $x) / $width);
+
+ $popup->Post($dt->rootx + $x, $dt->rooty + $y);
+ $popup->waitVariable(\$w->{renameval});
+ $popup->withdraw;
+
+ if (defined $w->{renameval} && $w->{renameval} ne $dir) {
+ my $cwd = Cwd::cwd();
+
+ if (chdir($pdir)) {
+ unless (rename($dir, $w->{renameval})) {
+ $w->messageBox(
+ -title => 'Unable to rename directory',
+ -message => "The directory '$dir' could not be renamed.\n$!",
+ -icon => 'error',
+ -type => 'OK',
+ );
+ }
+ chdir($cwd);
+ _showdir($dt, $pdir); # rebrowse to update the display
+ }
+ else {
+ warn "Unable to chdir() for rename() [$!]\n";
+ }
+ }
+}
+
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+Tk::DirSelect - Cross-platform directory selection widget.
+
+=head1 SYNOPSIS
+
+ use Tk::DirSelect;
+ my $ds = $mw->DirSelect();
+ my $dir = $ds->Show();
+
+=head1 DESCRIPTION
+
+This module provides a cross-platform directory selection widget. For
+systems running Microsoft Windows, this includes selection of local and
+mapped network drives. A context menu (right-click or E<lt>Button3E<gt>)
+allows the creation, renaming, and deletion of directories while
+browsing.
+
+Note: Perl/Tk 804 added the C<chooseDirectory> method which uses native
+system dialogs where available. (i.e. Windows) If you want a native feel
+for your program, you probably want to use that method instead --
+possibly using this module as a fallback for systems with older versions
+of Tk installed.
+
+=head1 METHODS
+
+=head2 C<DirSelect([-title =E<gt> 'title'], [options])>
+
+Constructs a new DirSelect widget as a child of the invoking object
+(usually a MainWindow).
+
+The title for the widget can be set by specifying C<-title =E<gt>
+'Title'>. Any other options provided will be passed through to the
+DirTree widget that displays directories, so be sure they're appropriate
+(e.g. C<-width>)
+
+=head2 C<Show([directory], [options])>
+
+Displays the DirSelect widget and returns the user selected directory or
+C<undef> if the operation is canceled.
+
+All arguments are optional. The first argument (if defined) is the
+initial directory to display. The default is to display the current
+working directory. Any additional options are passed through to the
+Popup() method. This means that you can do something like
+
+ $ds->Show(undef, -popover => $mw);
+
+to center the dialog over your application.
+
+=head1 DEPENDENCIES
+
+=over 4
+
+=item * Perl 5.004
+
+=item * Tk 800
+
+=item * Win32API::File (under Microsoft Windows only)
+
+=back
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright 2000-2001 Kristi Thompson <kristi at kristi.ca>
+Copyright 2002-2005,2010 Michael Carman <mjcarman at cpan.org>
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=cut
Property changes on: trunk/Master/tlpkg/installer/DirSelect.pm
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Modified: trunk/Master/tlpkg/installer/install-menu-perltk.pl
===================================================================
--- trunk/Master/tlpkg/installer/install-menu-perltk.pl 2018-04-29 00:37:13 UTC (rev 47480)
+++ trunk/Master/tlpkg/installer/install-menu-perltk.pl 2018-04-29 14:52:02 UTC (rev 47481)
@@ -5,11 +5,6 @@
# Copyright 2008 Reinhard Kotucha
# This file is licensed under the GNU General Public License version 2
# or any later version.
-#
-# TODO:
-# - make the fancy selector the default, at least on unix
-# - for w32 find out the necessary files for the fancy selector and move
-# them to the installer perl package
use strict;
$^W = 1;
@@ -22,14 +17,8 @@
require Tk::Dialog;
require Tk::DialogBox;
require Tk::PNG;
-#require Tk::ROText;
-#require Tk::ProgressBar;
require Tk::BrowseEntry;
-if ($::alternative_selector) {
- require Tk::DirTree;
-}
-
use utf8;
no utf8;
@@ -53,6 +42,8 @@
require("TeXLive/trans.pl");
load_translations();
+require("$::installerdir/tlpkg/installer/texdirsel.pl");
+
# @fileassocdesc also defined in install-tl
$::fileassocdesc[0] = __("None");
$::fileassocdesc[1] = __("Only new");
@@ -69,7 +60,7 @@
$::yesno[0] = __('No');
$::yesno[1] = __('Yes');
-my $mw;
+our $mw;
my $subframe;
my $mainwindow;
my $bin_toggle_button;
@@ -119,6 +110,8 @@
my $restrictedyesno;
my $adjustrepoyesno;
+my $sep = ($^O =~ /^MSWin32/) ? "\\" : "/";
+
$::run_menu = \&run_menu_perltk;
@@ -378,16 +371,9 @@
$texdirtext = $fr->Label(-anchor => 'w')
->grid(-row => $row, -column => 2, -padx => "2m");
if (!$opt_in_place) {
- if ($::alternative_selector) {
$texdir_toggle_button = $fr->Button(
- -text => __("Change"), -command => sub { menu_edit_texdir("TEXDIR"); })
+ -text => __("Change"), -command => \&change_path)
->grid(-row => $row, -column => 3, -sticky => "ew", -padx => "2m");
- } else {
- $texdir_toggle_button = $fr->Button(
- -text => __("Change"),
- -command => sub { menu_edit_vars_value("TEXDIR"); })
- ->grid(-row => $row, -column => 3, -sticky => "ew", -padx => "2m");
- }
}
@@ -1184,6 +1170,11 @@
menu_update_texts();
}
+sub callback_change_texdir {
+ my $val = shift;
+ callback_edit_directories('TEXDIR', $val);
+}
+
sub callback_edit_directories {
my ($key,$val) = @_;
my $home = getenv('HOME');
Modified: trunk/Master/tlpkg/installer/install-menu-wizard.pl
===================================================================
--- trunk/Master/tlpkg/installer/install-menu-wizard.pl 2018-04-29 00:37:13 UTC (rev 47480)
+++ trunk/Master/tlpkg/installer/install-menu-wizard.pl 2018-04-29 14:52:02 UTC (rev 47481)
@@ -14,6 +14,7 @@
require("TeXLive/trans.pl");
load_translations();
+require("$::installerdir/tlpkg/installer/texdirsel.pl");
#
# the following lists define which options are shown in the Option screen
@@ -82,10 +83,9 @@
my $prv;
my $nxt;
my $img;
-my $dest;
my $dest_display;
my $warning;
-my $mw;
+our $mw;
my $usedfont;
my $fmain;
my $fbuttons;
@@ -418,8 +418,7 @@
$counter->configure(-text => "2/4");
- $dest = $vars{'TEXDIR'};
- $dest_display = native_slashify($dest);
+ $dest_display = native_slashify($vars{'TEXDIR'});
my $lab = $fmain->Label(-text => __('Destination folder:'));
my $val = $fmain->Label(-textvar => \$dest_display);
@@ -491,27 +490,6 @@
$nxt->configure(-state => "disabled");
}
}
-
-sub change_path {
- my $val = $dest;
- my $sw = $mw->Toplevel(-title => "Changing TEXDIR");
- $sw->transient($mw);
- $sw->grab();
- $sw->Label(-text => __('Enter path for') . " TEXDIR: ")->pack(-padx => "2m", -pady => "2m");
- my $entry = $sw->Entry(-text => native_slashify($val), -width => 60);
- $entry->pack(-padx => "2m", -pady => "2m")->focus();
- my $f = $sw->Frame;
- my $okbutton = $f->Button(-text => __('Ok'), -width => 10,
- -relief => "ridge",
- -command => sub { $val = forward_slashify($entry->get); callback_change_texdir($val) ; $sw->destroy })->pack(-side => 'left', -padx => "2m", -pady => "2m");
- my $cancelbutton = $f->Button(-text => __('Cancel'), -relief => "ridge",
- -width => 10,
- -command => sub { $sw->destroy })->pack(-side => 'right', -padx => "2m", -pady => "2m");
- $f->pack(-expand => 'x');
- # bindings
- $sw->bind('<Return>' => [ $okbutton, 'Invoke']);
- $sw->bind('<Escape>' => [ $cancelbutton, 'Invoke']);
-}
sub callback_change_texdir {
my ($val) = @_;
@@ -540,8 +518,8 @@
$vars{'TEXMFSYSVAR'}="$texdirnoslash/texmf-var";
$vars{'TEXMFSYSCONFIG'}="$texdirnoslash/texmf-config";
}
- $dest = $vars{'TEXDIR'};
- $dest_display = native_slashify($dest); # useful as -textvar value in Labels
+ #$dest = $vars{'TEXDIR'};
+ $dest_display = native_slashify($vars{'TEXDIR'}); # useful as -textvar value in Labels
check_show_warning();
}
Added: trunk/Master/tlpkg/installer/texdirsel.pl
===================================================================
--- trunk/Master/tlpkg/installer/texdirsel.pl (rev 0)
+++ trunk/Master/tlpkg/installer/texdirsel.pl 2018-04-29 14:52:02 UTC (rev 47481)
@@ -0,0 +1,277 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+$^W = 1;
+
+require Cwd;
+require File::Spec;
+
+our $texlive_release;
+our %vars;
+our $mw;
+
+my $sep;
+if (win32()) {
+ $sep = "\\";
+} else {
+ $sep = "/";
+}
+
+sub change_path {
+
+ ### GUI SETUP ###
+
+ my $sw;
+ $sw->destroy if Tk::Exists($sw);
+ $sw = $mw->Toplevel(-title => "Changing TEXDIR");
+ $sw->transient($mw);
+ $sw->withdraw;
+ $sw->grab();
+
+ # define a larger font
+ my $lfont = $sw->fontCreate();
+ $sw->fontConfigure(
+ $lfont, -size => 1.2 * $mw->fontConfigure($lfont, -size));
+
+ my $fr0 = $sw->Frame(-padx => 10, -pady => 5)->pack;
+ $sw->Label(-text => __("Installation directory").": ", -font => $lfont)
+ ->pack(-in => $fr0, -side => 'left');
+ my $path_l = $sw->Label(-font => $lfont)
+ ->pack(-in => $fr0, -side => 'left');
+
+ my $fr = $sw->Frame->pack;
+ my $prefix_l = $sw->Label(-justify => 'right', -padx => 5)
+ ->grid(-in => $fr, -column => 0, -row => 0, -sticky => 'e');
+ $sw->Label(-text => $sep)
+ ->grid(-in => $fr, -column => 1, -row => 0);
+ my $name_l = $sw->Label(-justify => 'center', -padx => 5)
+ ->grid(-in => $fr, -column => 2, -row => 0);
+ $sw->Label(-text => $sep)
+ ->grid(-in => $fr, -column => 3, -row => 0);
+ my $rel_l = $sw->Label(-justify => 'left', -padx => 5)
+ ->grid(-in => $fr, -column => 4, -row => 0, -sticky => 'w');
+
+ my $prefix_b = $sw->Button(
+ -text => __("Change". '...'), -padx => 1, -pady => 3, -bd => 1)
+ ->grid(-in => $fr, -column => 0, -row => 1, -sticky => 'ew');
+ my $name_b = $sw->Button(
+ -text => __("Change"), -padx => 1, -pady => 3, -bd => 1)
+ ->grid(-in => $fr, -column => 2, -row => 1, -sticky => 'ew', -padx => 2);
+ my $rel_b = $sw->Button(
+ -text => __("Toggle"), -padx => 1, -pady => 3, -bd => 1)
+ ->grid(-in => $fr, -column => 4, -row => 1, -sticky => 'ew');
+
+ # warning about year component
+ my $warn_yr_l = $sw->Label(-anchor => 'e', -foreground => 'red')
+ ->pack(-fill =>'x', -expand => 1);
+
+ # ok and cancel buttons
+ my $frb = $sw->Frame->pack(-fill => 'x', -expand => 1);
+ my $ok_b = $sw->Button(
+ -text => __("Ok"),
+ -command => sub {
+ callback_change_texdir(forward_slashify($path_l->cget(-text)));
+ $sw->destroy;
+ })->pack(-in => $frb, -side => 'right');
+ my $q = $sw->Button(-text => __("Cancel"), -command => sub {$sw->destroy;})
+ ->pack(-in => $frb, -side => 'right');
+
+ if (win32()) {
+ $frb->Label(
+ -text =>
+ __("Localized directory names will be replaced by their real names"))
+ ->pack(-side => 'left');
+ }
+
+ # array of widgets needed by callbacks
+ my @wg = ($path_l, $prefix_l, $name_l, $rel_l, $ok_b, $warn_yr_l);
+
+ # callbacks which use @wg
+ $prefix_b->configure(-command => [\&browse_path, $sw, @wg]);
+ $name_b->configure(-command => [\&edit_name, $sw, @wg]);
+ $rel_b->configure(-command => [\&toggle_rel, @wg]);
+
+ # bindings
+ $sw->bind('<Return>' => [ $ok_b, 'Invoke']);
+ $sw->bind('<Escape>' => [ $q, 'Invoke']);
+
+ ### END GUI SETUP ###
+
+ my $val = $vars{'TEXDIR'};
+ $val = native_slashify($val);
+ $path_l->configure(-text => $val);
+
+ # release subdirectory at the end?
+ my $rel_pat = "[\\\\/]".$texlive_release."[\\\\/]?\$";
+
+ # calculate initial values based on existing $val (copied from TEXDIR)
+ my $initdir = File::Spec->rel2abs($val);
+ my $rel = "";
+ my $name = "";
+ # check for release subdirectory at the end and remove from initdir
+ if ($initdir =~ $rel_pat) {
+ $initdir =~ s!$rel_pat!!;
+ $rel = $texlive_release;
+ $rel_l->configure(-text => $texlive_release);
+ }
+ # now assign remaining final path component to name_l
+ if ($initdir =~ /[\\\/]([^\\\/]+)[\\\/]?$/) {
+ $name_l->configure(-text => $1);
+ $initdir =~ s/[\\\/][^\\\/]+[\\\/]?$//;
+ }
+
+ # backtrack remaining initdir to something that exists
+ # and assign it to prefix
+ while (! -d $initdir) {
+ my $initprev = $initdir;
+ $initdir =~ s/[\\\/][^\\\/]+[\\\/]?$//;
+ last if ($initdir eq $initprev);
+ }
+ if ($initdir eq "" or (win32() and $initdir =~ /:$/)) {
+ $initdir = $initdir . (win32() ? "\\" : "/");
+ }
+ $prefix_l->configure(-text => $initdir);
+ # display complete path in $path_l
+ update_full_path( @wg );
+ $sw->deiconify();
+ $sw->raise($mw);
+ $sw->grab();
+} # change_path
+
+sub update_full_path {
+ my $path_l = shift;
+ my $prefix_l = shift;
+ my $name_l = shift;
+ my $rel_l = shift;
+ my $ok_b = shift;
+ my $warn_yr_l = shift;
+
+ my $prefix = $prefix_l->cget(-text);
+ if ($prefix eq "" or (win32() and $prefix =~ /:$/)) {
+ $prefix_l->insert('end', $sep);
+ $prefix .= $sep;
+ }
+ my $name = $name_l->cget(-text);
+ if ($name =~ m![\\/]!) {
+ $name =~ s![\\/]!!g;
+ $name_l->delete(0, 'end');
+ $name_l->insert(0, $name);
+ }
+ $path_l->configure(
+ -text => File::Spec->catdir($prefix, $name, $rel_l->cget(-text)));
+ if (-d $prefix) {
+ $ok_b->configure(-state => 'normal');
+ } else {
+ $ok_b->configure(-state => 'disabled');
+ }
+ # check for release component
+ if ($rel_l->cget(-text) ne '') {
+ $warn_yr_l->configure(-text => '');
+ } else {
+ $warn_yr_l->configure(
+ -text => __('Release year component highly recommended!'));
+ }
+ return;
+} # update_full_path
+
+sub toggle_rel {
+ my $path_l = shift;
+ my $prefix_l = shift;
+ my $name_l = shift;
+ my $rel_l = shift;
+ my $ok_b = shift;
+ my $warn_yr_l = shift;
+
+ if ($rel_l->cget(-text) eq '') {
+ $rel_l->configure(-text => $texlive_release);
+ } else {
+ $rel_l->configure(-text => '');
+ }
+ update_full_path($path_l, $prefix_l, $name_l, $rel_l, $ok_b, $warn_yr_l);
+} # toggle_rel
+
+sub edit_name {
+ my $sw = shift; # parent window
+ my $path_l = shift;
+ my $prefix_l = shift;
+ my $name_l = shift;
+ my $rel_l = shift;
+ my $ok_b = shift;
+ my $warn_yr_l = shift;
+ my $ednm;
+ $ednm->destroy if Tk::Exists($ednm);
+ $ednm = $sw->Toplevel(-title => __("Changing directory name"));
+ $ednm->transient($sw);
+ $ednm->withdraw();
+
+ $ednm->Label(-text => __("Change name (slashes not allowed)"))
+ ->pack(-padx => 5, -pady => 5);
+ my $nm_e = $ednm->Entry(-width => 20)->pack(-pady => 5);
+ $nm_e->insert(0, $name_l->cget(-text));
+ my $fr = $ednm->Frame->pack(-fill => 'x', -expand => 1);
+ my $ok = $ednm->Button(
+ -text => __("OK"),
+ -command => sub {
+ my $nm = $nm_e->get;
+ if ($nm !~ m![\\/]!) {
+ $name_l->configure(-text => $nm);
+ update_full_path(
+ $path_l, $prefix_l, $name_l, $rel_l, $ok_b, $warn_yr_l);
+ $ednm->destroy();
+ } else {
+ $ednm->messageBox(
+ -icon => 'error',
+ -type => 'Ok',
+ -message => __("Illegal name"));
+ }
+ })->pack(-in => $fr, -side => 'right', -pady => 5, -padx => 5);
+ my $cancel = $ednm->Button(
+ -text => __("Cancel"),
+ -command => sub { $ednm->destroy(); })
+ ->pack(-in => $fr, -side => 'right');
+ $ednm->deiconify();
+ $ednm->raise($sw);
+ $ednm->grab();
+} # edit_name
+
+sub browse_path {
+ my $mw = shift;
+ my $path_l = shift;
+ my $prefix_l = shift;
+ my $name_l = shift;
+ my $rel_l = shift;
+ my $ok_b = shift;
+ my $warn_yr_l = shift;
+
+ my $retval = $prefix_l->cget(-text);
+ my $use_native = 0; # choice of directory browser
+ if ($^O =~ /^MSWin/i) {
+ $use_native = 1;
+ } else {
+ eval { require Tk::DirSelect; };
+ if ($@) {
+ eval { require installer::DirSelect; };
+ if ($@) {
+ $use_native = 1;
+ }
+ }
+ }
+ if ($use_native) {
+ $retval = $mw->chooseDirectory(
+ -initialdir => $retval,
+ -parent => $mw,
+ -title => __("Select prefix destination directory"),
+ );
+ } else {
+ my $fsdia = $mw->DirSelect(
+ -title => __("Select prefix destination directory"));
+ $retval = $fsdia->Show($retval, -popover => $mw);
+ $fsdia->destroy;
+ }
+ if (defined $retval and $retval ne "") {
+ $prefix_l->configure(-text => File::Spec->rel2abs($retval));
+ update_full_path($path_l, $prefix_l, $name_l, $rel_l, $ok_b, $warn_yr_l);
+ }
+ return;
+} # browse_path
Property changes on: trunk/Master/tlpkg/installer/texdirsel.pl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
More information about the tex-live-commits
mailing list