From a9ab728d2a8b514da67b964a845f2e5bb7308f60 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sat, 27 Feb 2021 14:17:34 +0000 Subject: Translations loaded in tlmgr and install-tl git-svn-id: svn://tug.org/texlive/trunk@57970 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/installer/DirSelect.pm | 503 ------------------------------------ 1 file changed, 503 deletions(-) delete mode 100644 Master/tlpkg/installer/DirSelect.pm (limited to 'Master/tlpkg/installer/DirSelect.pm') diff --git a/Master/tlpkg/installer/DirSelect.pm b/Master/tlpkg/installer/DirSelect.pm deleted file mode 100644 index 520a0db0bb7..00000000000 --- a/Master/tlpkg/installer/DirSelect.pm +++ /dev/null @@ -1,503 +0,0 @@ -#=============================================================================== -# 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 -- cgit v1.2.3