From 6ce5ae90e515f240707be95e88cfebfb89408bab Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sun, 29 Apr 2018 14:52:02 +0000 Subject: Browser dialog for TEXDIR git-svn-id: svn://tug.org/texlive/trunk@47481 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/installer/DirSelect.pm | 503 ++++++++++++++++++++++++++ Master/tlpkg/installer/install-menu-perltk.pl | 31 +- Master/tlpkg/installer/install-menu-wizard.pl | 32 +- Master/tlpkg/installer/texdirsel.pl | 277 ++++++++++++++ 4 files changed, 796 insertions(+), 47 deletions(-) create mode 100644 Master/tlpkg/installer/DirSelect.pm create mode 100755 Master/tlpkg/installer/texdirsel.pl (limited to 'Master/tlpkg') diff --git a/Master/tlpkg/installer/DirSelect.pm b/Master/tlpkg/installer/DirSelect.pm new file mode 100644 index 00000000000..520a0db0bb7 --- /dev/null +++ b/Master/tlpkg/installer/DirSelect.pm @@ -0,0 +1,503 @@ +#=============================================================================== +# Tk/DirSelect.pm +# Copyright (C) 2000-2001 Kristi Thompson +# Copyright (C) 2002-2005,2010 Michael Carman +# 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('', 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('' => sub {$menu->unpost}); + $w->{tree}->bind('' => [\&_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('', sub {$w->{renameval} = undef}); + $w->{rename}->bind('', sub {$w->{renameval} = undef}); + $w->{rename}->bind('', 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 EButton3E) +allows the creation, renaming, and deletion of directories while +browsing. + +Note: Perl/Tk 804 added the C 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 '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 +'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 + +Displays the DirSelect widget and returns the user selected directory or +C 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 +Copyright 2002-2005,2010 Michael Carman + +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 diff --git a/Master/tlpkg/installer/install-menu-perltk.pl b/Master/tlpkg/installer/install-menu-perltk.pl index c90344cb6a4..65598d42c0c 100644 --- a/Master/tlpkg/installer/install-menu-perltk.pl +++ b/Master/tlpkg/installer/install-menu-perltk.pl @@ -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; 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 @@ our %TRANS; 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 @@ if (win32() && is_seven()) { $::deskintdesc[2] = __("Launcher entry"); } $::yesno[0] = __('No'); $::yesno[1] = __('Yes'); -my $mw; +our $mw; my $subframe; my $mainwindow; my $bin_toggle_button; @@ -119,6 +110,8 @@ my $docyesno; my $restrictedyesno; my $adjustrepoyesno; +my $sep = ($^O =~ /^MSWin32/) ? "\\" : "/"; + $::run_menu = \&run_menu_perltk; @@ -378,16 +371,9 @@ Please select a different mirror.', $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 @@ sub callback_select_systems() { 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'); diff --git a/Master/tlpkg/installer/install-menu-wizard.pl b/Master/tlpkg/installer/install-menu-wizard.pl index dd58e0edd66..8cc4008e73c 100644 --- a/Master/tlpkg/installer/install-menu-wizard.pl +++ b/Master/tlpkg/installer/install-menu-wizard.pl @@ -14,6 +14,7 @@ $::menurevision = $1; 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 $can; 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 @@ sub ask_path { $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 @@ sub check_show_warning { $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('' => [ $okbutton, 'Invoke']); - $sw->bind('' => [ $cancelbutton, 'Invoke']); -} sub callback_change_texdir { my ($val) = @_; @@ -540,8 +518,8 @@ sub callback_change_texdir { $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(); } 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('' => [ $ok_b, 'Invoke']); + $sw->bind('' => [ $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 -- cgit v1.2.3