summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/ColorDialog.pm58
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm472
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/ColorSelect.pm414
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Config.pm2
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/DirSelect.pm503
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Event.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/IO.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MMutil.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm59
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Table.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Text.pm4
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/Tk.def4
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h4
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h2
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h2
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h3
16 files changed, 1054 insertions, 491 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorDialog.pm b/Master/tlpkg/tlperl/lib/Tk/ColorDialog.pm
new file mode 100755
index 00000000000..7b62eeca356
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ColorDialog.pm
@@ -0,0 +1,58 @@
+package Tk::ColorDialog;
+require Tk::Toplevel;
+use base qw(Tk::Toplevel);
+
+use vars qw($VERSION);
+$VERSION = '4.014';
+
+Construct Tk::Widget 'ColorDialog';
+
+sub Accept
+{
+ my $cw = shift;
+ $cw->withdraw;
+ $cw->{'done'} = 1;
+}
+
+sub Cancel
+{
+ my $cw = shift;
+# $cw->configure(-color => undef);
+ $cw->configure(-color => 'cancel');
+ $cw->Accept;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->SUPER::Populate($args);
+ $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ my $sel = $cw->ColorSelect;
+ my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
+ my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
+ Tk::grid($sel);
+ Tk::grid($accept,$cancel);
+ $cw->ConfigSpecs(DEFAULT => [$sel]);
+}
+
+sub Show
+{
+ my $cw = shift;
+ $cw->configure(@_) if @_;
+ $cw->Popup();
+ $cw->OnDestroy(sub { $cw->{'done'} = 0 }); # auto-cancel
+ $cw->waitVariable(\$cw->{'done'});
+ if (Tk::Exists($cw))
+ {
+ $cw->withdraw;
+ $cw->cget('-color');
+ }
+ else
+ {
+ undef;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm
index 82b38991f11..78f31fca4d4 100644
--- a/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm
@@ -1,474 +1,7 @@
-package Tk::ColorSelect; # XXX why is this the Tk::ColorSelect package?
-use strict;
-
-use vars qw($VERSION);
-$VERSION = '4.012'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
-
-use Tk qw(Ev);
-
-require Tk::Frame;
-
-use base qw(Tk::Frame);
-Construct Tk::Widget 'ColorSelect';
-
-sub Populate
-{
- my ($middle,$args) = @_;
- my($i, @a);
- my %seen_names;
- foreach $i ($middle->_rgbTxtPath) {
- local *FOO;
- next if ! open FOO, $i;
- my $middle_left = $middle->Frame;
- $middle_left->pack(
- -side => 'left',
- -padx => '0.25c',
- -pady => '0.25c',
- );
- my $names = $middle->Listbox(
- -width => 20,
- -height => 12,
- -relief => 'sunken',
- -borderwidth => 2,
- -exportselection => 0,
- );
- $middle->Advertise(Names => $names);
-
- $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]);
-
- my $scroll = $middle->Scrollbar(
- -orient => 'vertical',
- -command => ['yview', $names],
- -relief => 'sunken',
- -borderwidth => 2,
- );
- $names->configure(-yscrollcommand => ['set',$scroll]);
- $names->pack(-in => $middle_left, -side => 'left');
- $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y');
-
- while(<FOO>) {
- chomp;
- next if /^!/;
- my @a = split;
- my $color = join(' ', @a[3 .. $#a]);
- my $hex;
- eval { $hex = $middle->Hex($color); };
- if ($@) {
- #print STDERR "unknown color: '$color'\n";
- if ($@ =~ /unknown color name "/) {
- next;
- } else {
- chomp $@;
- die $@;
- }
- }
- if (!exists($seen_names{$hex}) ||
- length($seen_names{$hex}) > length($color)) {
- $seen_names{$hex} = $color;
- $names->insert('end', $color);
- }
- }
- close FOO;
- last;
- }
-
- # Create the three scales for editing the color, and the entry for typing
- # in a color value.
-
- my $middle_middle = $middle->Frame;
- $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y');
- my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'},
- -command => [ $middle, 'color_space'],
- -relief => 'raised',
- -options => [ ['HSB color space' => 'hsb'],
- ['RGB color space' => 'rgb'],
- ['CMY color space' => 'cmy']]);
- $mcm1->pack(-side => 'top', -fill => 'x');
-
- my(@middle_middle, @label, @scale);
- $middle_middle[0] = $middle_middle->Frame;
- $middle_middle[1] = $middle_middle->Frame;
- $middle_middle[2] = $middle_middle->Frame;
- $middle_middle[3] = $middle_middle->Frame;
- $middle_middle[0]->pack(-side => 'top', -expand => 1);
- $middle_middle[1]->pack(-side => 'top', -expand => 1);
- $middle_middle[2]->pack(-side => 'top', -expand => 1);
- $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x');
- $middle->{'Labels'} = ['zero','one','two'];
- foreach $i (0..2) {
- $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]);
- $scale[$i] = $middle->Scale(
- -from => 0,
- -to => 1000,
- '-length' => '6c',
- -orient => 'horizontal',
- -command => [\&scale_changed, $middle],
- );
- $scale[$i]->pack(
- -in => $middle_middle[$i],
- -side => 'top',
- -anchor => 'w',
- );
- $label[$i]->pack(
- -in => $middle_middle[$i],
- -side => 'top',
- -anchor => 'w',
- );
- }
- my $nameLabel = $middle->Label(-text => 'Name:');
- $middle->{'Entry'} = '';
- my $name = $middle->Entry(
- -relief => 'sunken',
- -borderwidth => 2,
- -textvariable => \$middle->{'Entry'},
- -width => 10,
-# For some reason giving this font causes problems at end of t/create.t
-# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
- );
-
- $nameLabel->pack(-in => $middle_middle[3], -side => 'left');
- $name->pack(
- -in => $middle_middle[3],
- -side => 'right',
- -expand => 1,
- -fill => 'x',
- );
- $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]);
-
- # Create the color display swatch on the right side of the window.
-
- my $middle_right = $middle->Frame;
- $middle_right->pack(
- -side => 'left',
- -pady => '.25c',
- -padx => '.25c',
- -anchor => 's',
- );
- my $swatch = $middle->Canvas(
- -width => '2.5c',
- -height => '5c',
- );
- my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c');
-
- my $value = $middle->Label(
- -textvariable => \$middle->{'color'},
- -width => 13,
- -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
- );
-
- $swatch->pack(
- -in => $middle_right,
- -side => 'top',
- -expand => 1,
- -fill => 'both',
- );
- $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c');
-
- $middle->ConfigSpecs(
- '-color_space' => ['METHOD', undef, undef, 'hsb'],
- '-initialcolor' => '-color',
- '-color' => ['METHOD', 'background', 'Background',
- $middle->cget('-background')]
- );
-
- $middle->{'swatch'} = $swatch;
- $middle->{'swatch_item'} = $swatch_item;
- $middle->{'scale'} = [@scale];
- $middle->{'red'} = 0;
- $middle->{'blue'} = 0;
- $middle->{'green'} = 0;
-
-}
-
-sub _rgbTxtPath
-{
- require Tk::Config;
- my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" }
- split /\s+/, $Tk::Config::xlib;
- (
- @xlibpath,
- '/usr/local/lib/X11/rgb.txt',
- '/usr/lib/X11/rgb.txt',
- '/usr/X11R6/lib/X11/rgb.txt',
- '/usr/local/X11R5/lib/X11/rgb.txt',
- '/X11/R5/lib/X11/rgb.txt',
- '/X11/R4/lib/rgb/rgb.txt',
- '/usr/openwin/lib/X11/rgb.txt',
- '/usr/share/X11/rgb.txt', # This is the Debian location
- '/usr/X11/share/X11/rgb.txt', # seen on a Mac OS X 10.5.1 system
- '/usr/X11R6/share/X11/rgb.txt', # seen on a OpenBSD 4.2 system
- '/etc/X11R6/rgb.txt',
- '/etc/X11/rgb.txt', # seen on HP-UX 11.31
- );
-}
-
-sub Hex
-{
- my $w = shift;
- my @rgb = (@_ == 3) ? @_ : $w->rgb(@_);
- sprintf('#%04x%04x%04x',@rgb)
-}
-
-sub color_space {
-
- my($objref, $space) = @_;
-
- if (@_ > 1)
- {
- my %Labels = ( 'rgb' => [qw(Red Green Blue)],
- 'cmy' => [qw(Cyan Magenta Yellow)],
- 'hsb' => [qw(Hue Saturation Brightness)] );
-
- # The procedure below is invoked when a new color space is selected. It
- # changes the labels on the scales and re-loads the scales with the
- # appropriate values for the current color in the new color space
-
- $space = 'hsb' unless (exists $Labels{$space});
- my $i;
- for $i (0..2)
- {
- $objref->{'Labels'}[$i] = $Labels{$space}->[$i];
- }
- $objref->{'color_space'} = $space;
- $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
- }
- return $objref->{'color_space'};
-} # color_space
-
-sub hsvToRgb {
-
- # The procedure below converts an HSB value to RGB. It takes hue,
- # saturation, and value components (floating-point, 0-1.0) as arguments,
- # and returns a list containing RGB components (integers, 0-65535) as
- # result. The code here is a copy of the code on page 616 of
- # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam.
-
- my($hue, $sat, $value) = @_;
- my($v, $i, $f, $p, $q, $t);
-
- $v = int(65535 * $value);
- return ($v, $v, $v) if $sat == 0;
- $hue *= 6;
- $hue = 0 if $hue >= 6;
- $i = int($hue);
- $f = $hue - $i;
- $p = int(65535 * $value * (1 - $sat));
- $q = int(65535 * $value * (1 - ($sat * $f)));
- $t = int(65535 * $value * (1 - ($sat * (1 - $f))));
- return ($v, $t, $p) if $i == 0;
- return ($q, $v, $p) if $i == 1;
- return ($p, $v, $t) if $i == 2;
- return ($p, $q, $v) if $i == 3;
- return ($t, $p, $v) if $i == 4;
- return ($v, $p, $q) if $i == 5;
-
-} # end hsvToRgb
-
-sub color
-{
- my ($objref,$name) = @_;
- if (@_ > 1 && defined($name) && length($name))
- {
- if ($name eq 'cancel') {
- $objref->{color} = undef;
- return;
- }
- my ($format, $shift);
- my ($red, $green, $blue);
-
- if ($name !~ /^#/)
- {
- ($red, $green, $blue) = $objref->{'swatch'}->rgb($name);
- }
- else
- {
- my $len = length $name;
- if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; }
- elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; }
- elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; }
- elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; }
- else {
- $objref->BackTrace(
- "ColorEditor error: syntax error in color name \"$name\"");
- return;
- }
- ($red,$green,$blue) = $name =~ /$format/;
- # Looks like a call for 'pack' or similar rather than eval
- eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;";
- $red = $red << $shift;
- $green = $green << $shift;
- $blue = $blue << $shift;
- }
- $objref->{'red'} = $red;
- $objref->{'blue'} = $blue;
- $objref->{'green'} = $green;
- my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue);
- $objref->{'color'} = $hex;
- $objref->{'Entry'} = $name;
- $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
- $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'},
- -fill => $objref->{'color'});
- }
- return $objref->{'color'};
-}
-
-sub rgbToHsv {
-
- # The procedure below converts an RGB value to HSB. It takes red, green,
- # and blue components (0-65535) as arguments, and returns a list
- # containing HSB components (floating-point, 0-1) as result. The code
- # here is a copy of the code on page 615 of "Fundamentals of Interactive
- # Computer Graphics" by Foley and Van Dam.
-
- my($red, $green, $blue) = @_;
- my($max, $min, $sat, $range, $hue, $rc, $gc, $bc);
-
- $max = ($red > $green) ? (($blue > $red) ? $blue : $red) :
- (($blue > $green) ? $blue : $green);
- $min = ($red < $green) ? (($blue < $red) ? $blue : $red) :
- (($blue < $green) ? $blue : $green);
- $range = $max - $min;
- if ($max == 0) {
- $sat = 0;
- } else {
- $sat = $range / $max;
- }
- if ($sat == 0) {
- $hue = 0;
- } else {
- $rc = ($max - $red) / $range;
- $gc = ($max - $green) / $range;
- $bc = ($max - $blue) / $range;
- $hue = ($max == $red)?(0.166667*($bc - $gc)):
- (($max == $green)?(0.166667*(2 + $rc - $bc)):
- (0.166667*(4 + $gc - $rc)));
- }
- $hue += 1 if $hue < 0;
- return ($hue, $sat, $max/65535);
-
-} # end rgbToHsv
-
-sub scale_changed {
-
- # The procedure below is invoked when one of the scales is adjusted. It
- # propagates color information from the current scale readings to
- # everywhere else that it is used.
-
- my($objref) = @_;
-
- return if $objref->{'updating'};
- my ($red, $green, $blue);
-
- if($objref->{'color_space'} eq 'rgb') {
- $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5);
- $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5);
- $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5);
- } elsif($objref->{'color_space'} eq 'cmy') {
- $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5);
- $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5);
- $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5);
- } else {
- ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0,
- $objref->{'scale'}->[1]->get/1000.0,
- $objref->{'scale'}->[2]->get/1000.0);
- }
- $objref->{'red'} = $red;
- $objref->{'blue'} = $blue;
- $objref->{'green'} = $green;
- $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue));
- $objref->idletasks;
-
-} # end scale_changed
-
-sub set_scales {
-
- my($objref) = @_;
- $objref->{'pending'} = 0;
- $objref->{'updating'} = 1;
-
- # The procedure below is invoked to update the scales from the current red,
- # green, and blue intensities. It's invoked after a change in the color
- # space and after a named color value has been loaded.
-
- my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'},
- $objref->{'green'});
-
- if($objref->{'color_space'} eq 'rgb') {
- $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5));
- $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5));
- $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5));
- } elsif($objref->{'color_space'} eq 'cmy') {
- $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5));
- $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5));
- $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5));
- } else {
- my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue);
- $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5));
- $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5));
- $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5));
- }
- $objref->{'updating'} = 0;
-
-} # end set_scales
-
-package Tk::ColorDialog;
-require Tk::Toplevel;
-use base qw(Tk::Toplevel);
-
-Construct Tk::Widget 'ColorDialog';
-
-sub Accept
-{
- my $cw = shift;
- $cw->withdraw;
- $cw->{'done'} = 1;
-}
-
-sub Cancel
-{
- my $cw = shift;
-# $cw->configure(-color => undef);
- $cw->configure(-color => 'cancel');
- $cw->Accept;
-}
-
-sub Populate
-{
- my ($cw,$args) = @_;
- $cw->SUPER::Populate($args);
- $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
- $cw->transient($cw->Parent->toplevel);
- $cw->withdraw;
- my $sel = $cw->ColorSelect;
- my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
- my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
- Tk::grid($sel);
- Tk::grid($accept,$cancel);
- $cw->ConfigSpecs(DEFAULT => [$sel]);
-}
-
-sub Show
-{
- my $cw = shift;
- $cw->configure(@_) if @_;
- $cw->Popup();
- $cw->OnDestroy(sub { $cw->{'done'} = 0 }); # auto-cancel
- $cw->waitVariable(\$cw->{'done'});
- if (Tk::Exists($cw))
- {
- $cw->withdraw;
- $cw->cget('-color');
- }
- else
- {
- undef;
- }
-}
-
package Tk::ColorEditor;
use vars qw($VERSION $SET_PALETTE);
-$VERSION = '4.009'; # was: sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.014';
use Tk qw(lsearch Ev);
use Tk::Toplevel;
@@ -479,6 +12,9 @@ Construct Tk::Widget 'ColorEditor';
use Tk::Dialog;
use Tk::Pretty;
+use Tk::ColorSelect ();
+use Tk::ColorDialog ();
+
BEGIN { $SET_PALETTE = 'Set Palette' };
use subs qw(color_space hsvToRgb rgbToHsv);
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorSelect.pm b/Master/tlpkg/tlperl/lib/Tk/ColorSelect.pm
new file mode 100755
index 00000000000..385213e4363
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ColorSelect.pm
@@ -0,0 +1,414 @@
+package Tk::ColorSelect; # XXX why is this the Tk::ColorSelect package?
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.014';
+
+use Tk qw(Ev);
+
+require Tk::Frame;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'ColorSelect';
+
+sub Populate
+{
+ my ($middle,$args) = @_;
+ my($i, @a);
+ my %seen_names;
+ foreach $i ($middle->_rgbTxtPath) {
+ local *FOO;
+ next if ! open FOO, $i;
+ my $middle_left = $middle->Frame;
+ $middle_left->pack(
+ -side => 'left',
+ -padx => '0.25c',
+ -pady => '0.25c',
+ );
+ my $names = $middle->Listbox(
+ -width => 20,
+ -height => 12,
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -exportselection => 0,
+ );
+ $middle->Advertise(Names => $names);
+
+ $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]);
+
+ my $scroll = $middle->Scrollbar(
+ -orient => 'vertical',
+ -command => ['yview', $names],
+ -relief => 'sunken',
+ -borderwidth => 2,
+ );
+ $names->configure(-yscrollcommand => ['set',$scroll]);
+ $names->pack(-in => $middle_left, -side => 'left');
+ $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y');
+
+ while(<FOO>) {
+ chomp;
+ next if /^!/;
+ my @a = split;
+ my $color = join(' ', @a[3 .. $#a]);
+ my $hex;
+ eval { $hex = $middle->Hex($color); };
+ if ($@) {
+ #print STDERR "unknown color: '$color'\n";
+ if ($@ =~ /unknown color name "/) {
+ next;
+ } else {
+ chomp $@;
+ die $@;
+ }
+ }
+ if (!exists($seen_names{$hex}) ||
+ length($seen_names{$hex}) > length($color)) {
+ $seen_names{$hex} = $color;
+ $names->insert('end', $color);
+ }
+ }
+ close FOO;
+ last;
+ }
+
+ # Create the three scales for editing the color, and the entry for typing
+ # in a color value.
+
+ my $middle_middle = $middle->Frame;
+ $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y');
+ my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'},
+ -command => [ $middle, 'color_space'],
+ -relief => 'raised',
+ -options => [ ['HSB color space' => 'hsb'],
+ ['RGB color space' => 'rgb'],
+ ['CMY color space' => 'cmy']]);
+ $mcm1->pack(-side => 'top', -fill => 'x');
+
+ my(@middle_middle, @label, @scale);
+ $middle_middle[0] = $middle_middle->Frame;
+ $middle_middle[1] = $middle_middle->Frame;
+ $middle_middle[2] = $middle_middle->Frame;
+ $middle_middle[3] = $middle_middle->Frame;
+ $middle_middle[0]->pack(-side => 'top', -expand => 1);
+ $middle_middle[1]->pack(-side => 'top', -expand => 1);
+ $middle_middle[2]->pack(-side => 'top', -expand => 1);
+ $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x');
+ $middle->{'Labels'} = ['zero','one','two'];
+ foreach $i (0..2) {
+ $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]);
+ $scale[$i] = $middle->Scale(
+ -from => 0,
+ -to => 1000,
+ '-length' => '6c',
+ -orient => 'horizontal',
+ -command => [\&scale_changed, $middle],
+ );
+ $scale[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ $label[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ }
+ my $nameLabel = $middle->Label(-text => 'Name:');
+ $middle->{'Entry'} = '';
+ my $name = $middle->Entry(
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -textvariable => \$middle->{'Entry'},
+ -width => 10,
+# For some reason giving this font causes problems at end of t/create.t
+# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $nameLabel->pack(-in => $middle_middle[3], -side => 'left');
+ $name->pack(
+ -in => $middle_middle[3],
+ -side => 'right',
+ -expand => 1,
+ -fill => 'x',
+ );
+ $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]);
+
+ # Create the color display swatch on the right side of the window.
+
+ my $middle_right = $middle->Frame;
+ $middle_right->pack(
+ -side => 'left',
+ -pady => '.25c',
+ -padx => '.25c',
+ -anchor => 's',
+ );
+ my $swatch = $middle->Canvas(
+ -width => '2.5c',
+ -height => '5c',
+ );
+ my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c');
+
+ my $value = $middle->Label(
+ -textvariable => \$middle->{'color'},
+ -width => 13,
+ -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $swatch->pack(
+ -in => $middle_right,
+ -side => 'top',
+ -expand => 1,
+ -fill => 'both',
+ );
+ $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c');
+
+ $middle->ConfigSpecs(
+ '-color_space' => ['METHOD', undef, undef, 'hsb'],
+ '-initialcolor' => '-color',
+ '-color' => ['METHOD', 'background', 'Background',
+ $middle->cget('-background')]
+ );
+
+ $middle->{'swatch'} = $swatch;
+ $middle->{'swatch_item'} = $swatch_item;
+ $middle->{'scale'} = [@scale];
+ $middle->{'red'} = 0;
+ $middle->{'blue'} = 0;
+ $middle->{'green'} = 0;
+
+}
+
+sub _rgbTxtPath
+{
+ require Tk::Config;
+ my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" }
+ split /\s+/, $Tk::Config::xlib;
+ (
+ @xlibpath,
+ '/usr/local/lib/X11/rgb.txt',
+ '/usr/lib/X11/rgb.txt',
+ '/usr/X11R6/lib/X11/rgb.txt',
+ '/usr/local/X11R5/lib/X11/rgb.txt',
+ '/X11/R5/lib/X11/rgb.txt',
+ '/X11/R4/lib/rgb/rgb.txt',
+ '/usr/openwin/lib/X11/rgb.txt',
+ '/usr/share/X11/rgb.txt', # This is the Debian location
+ '/usr/X11/share/X11/rgb.txt', # seen on a Mac OS X 10.5.1 system
+ '/usr/X11R6/share/X11/rgb.txt', # seen on a OpenBSD 4.2 system
+ '/etc/X11R6/rgb.txt',
+ '/etc/X11/rgb.txt', # seen on HP-UX 11.31
+ );
+}
+
+sub Hex
+{
+ my $w = shift;
+ my @rgb = (@_ == 3) ? @_ : $w->rgb(@_);
+ sprintf('#%04x%04x%04x',@rgb)
+}
+
+sub color_space {
+
+ my($objref, $space) = @_;
+
+ if (@_ > 1)
+ {
+ my %Labels = ( 'rgb' => [qw(Red Green Blue)],
+ 'cmy' => [qw(Cyan Magenta Yellow)],
+ 'hsb' => [qw(Hue Saturation Brightness)] );
+
+ # The procedure below is invoked when a new color space is selected. It
+ # changes the labels on the scales and re-loads the scales with the
+ # appropriate values for the current color in the new color space
+
+ $space = 'hsb' unless (exists $Labels{$space});
+ my $i;
+ for $i (0..2)
+ {
+ $objref->{'Labels'}[$i] = $Labels{$space}->[$i];
+ }
+ $objref->{'color_space'} = $space;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ }
+ return $objref->{'color_space'};
+} # color_space
+
+sub hsvToRgb {
+
+ # The procedure below converts an HSB value to RGB. It takes hue,
+ # saturation, and value components (floating-point, 0-1.0) as arguments,
+ # and returns a list containing RGB components (integers, 0-65535) as
+ # result. The code here is a copy of the code on page 616 of
+ # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam.
+
+ my($hue, $sat, $value) = @_;
+ my($v, $i, $f, $p, $q, $t);
+
+ $v = int(65535 * $value);
+ return ($v, $v, $v) if $sat == 0;
+ $hue *= 6;
+ $hue = 0 if $hue >= 6;
+ $i = int($hue);
+ $f = $hue - $i;
+ $p = int(65535 * $value * (1 - $sat));
+ $q = int(65535 * $value * (1 - ($sat * $f)));
+ $t = int(65535 * $value * (1 - ($sat * (1 - $f))));
+ return ($v, $t, $p) if $i == 0;
+ return ($q, $v, $p) if $i == 1;
+ return ($p, $v, $t) if $i == 2;
+ return ($p, $q, $v) if $i == 3;
+ return ($t, $p, $v) if $i == 4;
+ return ($v, $p, $q) if $i == 5;
+
+} # end hsvToRgb
+
+sub color
+{
+ my ($objref,$name) = @_;
+ if (@_ > 1 && defined($name) && length($name))
+ {
+ if ($name eq 'cancel') {
+ $objref->{color} = undef;
+ return;
+ }
+ my ($format, $shift);
+ my ($red, $green, $blue);
+
+ if ($name !~ /^#/)
+ {
+ ($red, $green, $blue) = $objref->{'swatch'}->rgb($name);
+ }
+ else
+ {
+ my $len = length $name;
+ if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; }
+ elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; }
+ elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; }
+ elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; }
+ else {
+ $objref->BackTrace(
+ "ColorEditor error: syntax error in color name \"$name\"");
+ return;
+ }
+ ($red,$green,$blue) = $name =~ /$format/;
+ # Looks like a call for 'pack' or similar rather than eval
+ eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;";
+ $red = $red << $shift;
+ $green = $green << $shift;
+ $blue = $blue << $shift;
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue);
+ $objref->{'color'} = $hex;
+ $objref->{'Entry'} = $name;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'},
+ -fill => $objref->{'color'});
+ }
+ return $objref->{'color'};
+}
+
+sub rgbToHsv {
+
+ # The procedure below converts an RGB value to HSB. It takes red, green,
+ # and blue components (0-65535) as arguments, and returns a list
+ # containing HSB components (floating-point, 0-1) as result. The code
+ # here is a copy of the code on page 615 of "Fundamentals of Interactive
+ # Computer Graphics" by Foley and Van Dam.
+
+ my($red, $green, $blue) = @_;
+ my($max, $min, $sat, $range, $hue, $rc, $gc, $bc);
+
+ $max = ($red > $green) ? (($blue > $red) ? $blue : $red) :
+ (($blue > $green) ? $blue : $green);
+ $min = ($red < $green) ? (($blue < $red) ? $blue : $red) :
+ (($blue < $green) ? $blue : $green);
+ $range = $max - $min;
+ if ($max == 0) {
+ $sat = 0;
+ } else {
+ $sat = $range / $max;
+ }
+ if ($sat == 0) {
+ $hue = 0;
+ } else {
+ $rc = ($max - $red) / $range;
+ $gc = ($max - $green) / $range;
+ $bc = ($max - $blue) / $range;
+ $hue = ($max == $red)?(0.166667*($bc - $gc)):
+ (($max == $green)?(0.166667*(2 + $rc - $bc)):
+ (0.166667*(4 + $gc - $rc)));
+ }
+ $hue += 1 if $hue < 0;
+ return ($hue, $sat, $max/65535);
+
+} # end rgbToHsv
+
+sub scale_changed {
+
+ # The procedure below is invoked when one of the scales is adjusted. It
+ # propagates color information from the current scale readings to
+ # everywhere else that it is used.
+
+ my($objref) = @_;
+
+ return if $objref->{'updating'};
+ my ($red, $green, $blue);
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } else {
+ ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0,
+ $objref->{'scale'}->[1]->get/1000.0,
+ $objref->{'scale'}->[2]->get/1000.0);
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue));
+ $objref->idletasks;
+
+} # end scale_changed
+
+sub set_scales {
+
+ my($objref) = @_;
+ $objref->{'pending'} = 0;
+ $objref->{'updating'} = 1;
+
+ # The procedure below is invoked to update the scales from the current red,
+ # green, and blue intensities. It's invoked after a change in the color
+ # space and after a named color value has been loaded.
+
+ my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'},
+ $objref->{'green'});
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5));
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5));
+ } else {
+ my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue);
+ $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5));
+ $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5));
+ $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5));
+ }
+ $objref->{'updating'} = 0;
+
+} # end set_scales
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Config.pm b/Master/tlpkg/tlperl/lib/Tk/Config.pm
index 8d4f62868cc..fcb413bce3d 100644
--- a/Master/tlpkg/tlperl/lib/Tk/Config.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/Config.pm
@@ -2,7 +2,7 @@
package Tk::Config;
require Exporter;
use base qw(Exporter);
-$VERSION = '804.03';
+$VERSION = '804.032';
$inc = '-I$(TKDIR) -I$(TKDIR)/pTk/mTk/xlib';
$define = '';
$xlib = '';
diff --git a/Master/tlpkg/tlperl/lib/Tk/DirSelect.pm b/Master/tlpkg/tlperl/lib/Tk/DirSelect.pm
new file mode 100755
index 00000000000..85e402f131c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DirSelect.pm
@@ -0,0 +1,503 @@
+#===============================================================================
+# Tk/DirSelect.pm
+# Copyright (C) 2000-2001 Kristi Thompson <kristi@kristi.ca>
+# Copyright (C) 2002-2005,2010 Michael Carman <mjcarman@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@kristi.ca>
+Copyright 2002-2005,2010 Michael Carman <mjcarman@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
diff --git a/Master/tlpkg/tlperl/lib/Tk/Event.pm b/Master/tlpkg/tlperl/lib/Tk/Event.pm
index dec4aaad3d7..e9253bef602 100644
--- a/Master/tlpkg/tlperl/lib/Tk/Event.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/Event.pm
@@ -1,9 +1,9 @@
package Tk::Event;
use vars qw($VERSION $XS_VERSION @EXPORT_OK);
END { CleanupGlue() }
-$VERSION = '4.024'; # was: sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
-$XS_VERSION = '804.030';
-$XS_VERSION = eval $XS_VERSION;
+$VERSION = '4.030';
+$XS_VERSION = '804.032';
+$XS_VERSION =~ s{_}{};
use base qw(Exporter);
use XSLoader;
@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
diff --git a/Master/tlpkg/tlperl/lib/Tk/IO.pm b/Master/tlpkg/tlperl/lib/Tk/IO.pm
index 2ce1e172ebc..ea9acf582a2 100644
--- a/Master/tlpkg/tlperl/lib/Tk/IO.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/IO.pm
@@ -1,7 +1,7 @@
package Tk::IO;
use strict;
use vars qw($VERSION);
-$VERSION = '4.005'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $
+$VERSION = '4.006';
require 5.002;
use Tk::Event qw($XS_VERSION);
diff --git a/Master/tlpkg/tlperl/lib/Tk/MMutil.pm b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm
index 1a69e56c12c..7a78c1b7ebe 100644
--- a/Master/tlpkg/tlperl/lib/Tk/MMutil.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm
@@ -9,7 +9,7 @@ use Carp;
use File::Basename;
use vars qw($VERSION);
-$VERSION = '4.024';
+$VERSION = '4.025';
# warn __FILE__." $VERSION\n";
@@ -551,7 +551,7 @@ sub TkExtMakefile
$i = "-I$tk $i";
$i = "-I$ptk $i";
}
- if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
+ if ($IsWin32 && $Config{'cc'} =~ /gcc/i)
{
my $base = $Config{'libpth'};
#$base =~ s#lib$#i386-mingw32/lib#;
diff --git a/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm
index 3c3cba71c09..b15b996995c 100644
--- a/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm
@@ -11,8 +11,7 @@ $SIG{__DIE__} = \&Carp::confess;
use vars qw($VERSION);
-#$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
-$VERSION = '4.014';
+$VERSION = '4.015';
sub scan_file;
@@ -246,9 +245,16 @@ sub command_line
warn "Ignoring $1\n";
}
}
- # force /usr/include to be last element of @include
- push @include, $Config{'usrinc'}
- if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
+ # force /usr/include (and other system directories) to be last element of @include
+ if ($Config{ccname} eq 'gcc')
+ {
+ push @include, parse_gcc_inc_search_list();
+ }
+ else
+ {
+ push @include, $Config{'usrinc'}
+ if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
+ }
# warn "Include:@include\n";
while (@files)
{
@@ -287,6 +293,49 @@ sub command_line
return $data;
}
+sub parse_gcc_inc_search_list
+{
+ our @GCC_INC_SEARCH_LIST;
+ return @GCC_INC_SEARCH_LIST if @GCC_INC_SEARCH_LIST;
+
+ require File::Spec;
+ my $cmd = "$Config{cc} -xc -E -v -";
+ my @inc;
+ eval
+ {
+ open my $fh, "-|", "$cmd 2>&1 <".File::Spec->devnull
+ or die "Error while running $cmd: $!";
+
+ my $in_search_list;
+ while(<$fh>)
+ {
+ if (/^#include <\.\.\.> search starts here:/)
+ {
+ $in_search_list = 1;
+ }
+ elsif ($in_search_list)
+ {
+ last if /^End of search list/;
+ chomp;
+ s/^\s+//;
+ push @inc, $_;
+ }
+ }
+ };
+ if ($@)
+ {
+ warn $@;
+ }
+ if (!@inc)
+ {
+ # Fallback: add /usr/include
+ @inc = $Config{'usrinc'}
+ if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
+ }
+ @GCC_INC_SEARCH_LIST = @inc;
+ @inc;
+}
+
1;
__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Table.pm b/Master/tlpkg/tlperl/lib/Tk/Table.pm
index 2eae67fbd97..8116c012a09 100644
--- a/Master/tlpkg/tlperl/lib/Tk/Table.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/Table.pm
@@ -5,7 +5,7 @@ package Tk::Table;
use strict;
use vars qw($VERSION);
-$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+$VERSION = '4.016';
use AutoLoader;
use base qw(Tk::Frame);
@@ -392,8 +392,8 @@ sub clear {
my $self = shift;
my $rows = $self->cget(-rows);
my $cols = $self->cget(-columns);
- foreach my $r (1 .. $rows) {
- foreach my $c (1 .. $cols) {
+ foreach my $r (0 .. $rows-1) {
+ foreach my $c (0 .. $cols-1) {
my $old = $self->get( $r, $c );
next unless $old;
$self->LostSlave($old);
diff --git a/Master/tlpkg/tlperl/lib/Tk/Text.pm b/Master/tlpkg/tlperl/lib/Tk/Text.pm
index da41159252b..2d87bbff49d 100644
--- a/Master/tlpkg/tlperl/lib/Tk/Text.pm
+++ b/Master/tlpkg/tlperl/lib/Tk/Text.pm
@@ -21,7 +21,7 @@ use Text::Tabs;
use vars qw($VERSION);
#$VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/;
-$VERSION = '4.028';
+$VERSION = '4.029';
use Tk qw(Ev $XS_VERSION);
use base qw(Tk::Clipboard Tk::Widget);
@@ -1365,7 +1365,7 @@ sub Contents
}
else
{
- return $w->get('1.0','end');
+ return $w->get('1.0','end -1c');
}
}
diff --git a/Master/tlpkg/tlperl/lib/Tk/Tk.def b/Master/tlpkg/tlperl/lib/Tk/Tk.def
new file mode 100755
index 00000000000..4668be8d5c1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Tk.def
@@ -0,0 +1,4 @@
+EXPORTS
+ boot_Tk
+ _boot_Tk = boot_Tk
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h b/Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h
index 4598291f872..b09cede6bfb 100644
--- a/Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h
+++ b/Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h
@@ -4,10 +4,6 @@
#define STATIC_BUILD
-#ifdef bool
-#undef bool
-#endif
-
#include "tkConfig.h"
#define TCL_NO_DEPRECATED
diff --git a/Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h b/Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h
index b1733b64e18..90cee98909b 100644
--- a/Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h
+++ b/Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h
@@ -244,7 +244,7 @@ typedef struct GridStruct {
TixFont font; /* Default font used by the DItems. */
/* Text drawing */
- Cursor cursor; /* Current cursor for window, or None. */
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
/* For highlights */
int highlightWidth; /* Width in pixels of highlight to draw
diff --git a/Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h b/Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h
index 52584a022b8..314b4ec4c6c 100644
--- a/Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h
+++ b/Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h
@@ -77,7 +77,7 @@ typedef struct ListStruct {
TixFont font; /* Default font used by the DItems. */
/* Text drawing */
- Cursor cursor; /* Current cursor for window, or None. */
+ Tk_Cursor cursor; /* Current cursor for window, or None. */
/* For highlights */
int highlightWidth; /* Width in pixels of highlight to draw
diff --git a/Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h b/Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h
index 02cc8036e79..fd15066b441 100644
--- a/Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h
+++ b/Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h
@@ -1,7 +1,10 @@
#ifndef _TKCONFIG
#define _TKCONFIG
#define ANSI_SIGNED_CHAR 1
+#define CAN_COPSTASH_SET_NULL 1
#define HAS_STDARG 1
+#define HAS_SVIV_NOMG 1
+#define HAS_SVNV_NOMG 1
#define HAVE_LIMITS_H 1
#define LSEEK_TYPE long long
#define SELECT_MASK Perl_fd_set