diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Tk/ColorDialog.pm | 58 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm | 472 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Tk/ColorSelect.pm | 414 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Config.pm | 2 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Tk/DirSelect.pm | 503 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Event.pm | 6 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/IO.pm | 2 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/MMutil.pm | 4 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm | 59 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Table.pm | 6 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Text.pm | 4 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Tk/Tk.def | 4 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/pTk/Lang.h | 4 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/pTk/tixGrid.h | 2 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/pTk/tixTList.h | 2 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/pTk/tkConfig.h | 3 |
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 |