diff options
Diffstat (limited to 'Master/tlpkg/installer/texdirsel.pl')
-rwxr-xr-x | Master/tlpkg/installer/texdirsel.pl | 277 |
1 files changed, 0 insertions, 277 deletions
diff --git a/Master/tlpkg/installer/texdirsel.pl b/Master/tlpkg/installer/texdirsel.pl deleted file mode 100755 index dffced3beaa..00000000000 --- a/Master/tlpkg/installer/texdirsel.pl +++ /dev/null @@ -1,277 +0,0 @@ -#!/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 |