summaryrefslogtreecommitdiff
path: root/Master/tlpkg/installer/texdirsel.pl
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2018-04-29 14:52:02 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2018-04-29 14:52:02 +0000
commit6ce5ae90e515f240707be95e88cfebfb89408bab (patch)
tree2d4bbdcdf2c2fd4478af69810d33a721f69d7fde /Master/tlpkg/installer/texdirsel.pl
parent15605b628826392909b2230fd4716d43a61df365 (diff)
Browser dialog for TEXDIR
git-svn-id: svn://tug.org/texlive/trunk@47481 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer/texdirsel.pl')
-rwxr-xr-xMaster/tlpkg/installer/texdirsel.pl277
1 files changed, 277 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/texdirsel.pl b/Master/tlpkg/installer/texdirsel.pl
new file mode 100755
index 00000000000..dffced3beaa
--- /dev/null
+++ b/Master/tlpkg/installer/texdirsel.pl
@@ -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