@@ -1,3 +1,84 @@
+Tk-804.032 release (2014-01-26)
+------------------
+
+This is basically the same like Tk-804.031_503.
+
+Tk-804.031_503 release (2013-12-07)
+----------------------
+
+Fixes
+ Regain compatibility for perl < 5.8.9
+ (SvIV_nomg is not available with earlier perls).
+
+Tests
+ wm-time.t more robust against GNOME Shell slowness.
+
+Tk-804.031_502 release (2013-12-01)
+----------------------
+
+Fixes
+ Enable libpng configure for all Solaris architectures.
+
+Documentation
+ Update INSTALL, README-ActiveState.txt, and README-Strawberry.txt
+ documents.
+
+Tk-804.031_501 release (2013-11-18)
+----------------------
+
+Fixes
+ Fix gamma setting for PNG images (was only broken in 804.031_500).
+
+ Fix clang compilation error (was only broken in 804.031_500).
+
+Tests
+ Some tests are now more robust.
+
+Tk-804.031_500 release (2013-11-17)
+----------------------
+
+Fixes
+ RT# 88210: fix compilation for perl 5.19.0+ ("undef bool").
+
+ RT# 90077: floating number issue with -textvariable variables.
+
+ RT# 89621: avoid segfaults during global destruction (by Gisle Aas).
+
+ RT# 87016: compatibility for libpng 1.6.x.
+
+ RT# 86988: use cflags/libs information from pkg-config zlib.
+
+ RT# 89261: split Tk/ColorEditor.pm into three .pm files.
+
+ RT# 71718: fix compilation issue with 64bit Strawberry Perl (Tk_Cursor).
+
+ Fail gracefully if no font could be allocated.
+
+ ptksh: storing the history works now also under Windows.
+
+ Better handling if libpng's configure fails.
+
+Documentation
+ Changes to README.linux (dependency requirements, fontconfig) and
+ README.cygwin.
+
+ Document special Tk::Table behavior regarding -takefocus => 0.
+
+Tests
+ New test files (eventGenerate.t, sv.t) and new test cases
+ (eventGenerate in optmenu.t).
+
+ More test tweaks (e.g. skip some tests if the required fixed font is
+ unavailable, see with_fixed_font in TkTest.pm, workaround some fvwm2
+ problems in wm-tcl.t, protect from haning wm-time.t).
+
+ checked_test_harness() skips testing if no font could be allocated.
+
+ No test request user positioning windows anymore (for old window
+ managers like twm).
+
+ Configuration file for travis-ci.
+
Tk-804.031 release (2013-05-25)
----------
@@ -91,7 +172,7 @@ Fixes
RT #70429: show correct file name if image loading failed. Also
systematically searched and fixed other bad uses of Tcl_AppendResult.
- RT #70423: provide inuse method for Tk::Image
+ RT #70243: provide inuse method for Tk::Image
Fixed a possible segfault when using canvas' select clear method.
@@ -1,8 +1,8 @@
package Tk::Event;
use vars qw($VERSION $XS_VERSION @EXPORT_OK);
END { CleanupGlue() }
-$VERSION = '4.026';
-$XS_VERSION = '804.031';
+$VERSION = '4.030';
+$XS_VERSION = '804.032';
$XS_VERSION =~ s{_}{};
use base qw(Exporter);
use XSLoader;
@@ -13,5 +13,5 @@ sub MY::test_via_harness
{
my($self, $perl, $tests) = @_;
qq{\t$perl "-I../t" "-MTkTest" }.
- qq{"-e" "checked_test_harness('\$(TKDIR)/xt/skip_all.t', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
+ qq{"-e" "checked_test_harness('\$(TKDIR)/xt', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
@@ -1,3 +1,31 @@
+Perl/Tk can be installed using:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+On Windows platform, replace make by either dmake or nmake. Please
+read README-Strawberry.txt and README-ActiveState.txt for additional
+information for Strawberry Perl respective ActivePerl.
+
+For other systems, please refer to the specific README.$OS file for
+additional information.
+
+After installation, a demonstration program may be started using:
+
+ widget
+
+Compiled third-party Perl/Tk modules have to be recompiled after
+installing a new Perl/Tk version. Some known such modules are:
+* Tk::TableMatrix
+* Tk::Zinc
+* Tk::TIFF
+* Tk::Canvas::Point
+
+---------------------------------------------------------
+Older and probabably outdated notes follow:
+
This file was pre-historic - so I have pruned it to the essentials,
and the bits that still looked correct.
@@ -41,7 +41,7 @@ sub MY::test_via_harness
{
my($self, $perl, $tests) = @_;
qq{\t$perl "-I../t" "-MTkTest" }.
- qq{"-e" "checked_test_harness('\$(TKDIR)/xt/skip_all.t', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
+ qq{"-e" "checked_test_harness('\$(TKDIR)/xt', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
package MY;
@@ -6,7 +6,7 @@ bin/perms
bin/tkman
bin/unres
bin/uselib
-build Perl Script to rebuild "perl build"
+build_ptk Perl Script to rebuild "perl build"
Canvas/Canvas.pm
Canvas/Canvas.xs
Canvas/canvtxt
@@ -1986,6 +1986,7 @@ t/dialogbox.t
t/dirtree.t
t/entry.t
t/errordialog.t
+t/eventGenerate.t
t/exefiles.t
t/fbox.t
t/fileevent.t
@@ -2026,6 +2027,7 @@ t/TkTest.pm
t/Tkxs.t
t/trace1.t
t/slaves.t
+t/sv.t
t/unicode.t
t/widget.t
t/wm.t
@@ -2097,8 +2099,10 @@ Tk/cbxarrow.xbm
Tk/Checkbutton.pm
Tk/Clipboard.pm
Tk/CmdLine.pm
+Tk/ColorDialog.pm
Tk/ColorEdit.xpm
Tk/ColorEditor.pm
+Tk/ColorSelect.pm
Tk/Configure.pm
Tk/Credits Credits for .gif files
Tk/Derived.pm
@@ -2212,6 +2216,6 @@ Xlib/Xlib.xs
xt/font_attrs.t
xt/mw_segfault.t
xt/rt7474.t
-xt/skip_all.t
-META.yml Module YAML meta-data (added by MakeMaker)
-META.json Module JSON meta-data (added by MakeMaker)
+xt/skip_all_font.t
+xt/skip_all_mw.t
+META.yml Module meta-data (added by MakeMaker)
@@ -1,47 +0,0 @@
-{
- "abstract" : "Tk - a Graphical User Interface Toolkit",
- "author" : [
- "nick@ing-simmons.net (Nick Ing-Simmons)"
- ],
- "dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921",
- "license" : [
- "unrestricted"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "Tk",
- "no_index" : {
- "directory" : [
- "t",
- "inc"
- ]
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "0"
- }
- },
- "configure" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "0"
- }
- },
- "runtime" : {
- "requires" : {
- "Encode" : "0",
- "Test::More" : "0"
- }
- }
- },
- "release_status" : "stable",
- "resources" : {
- "repository" : {
- "url" : "http://github.com/eserte/perl-tk"
- }
- },
- "version" : "804.031"
-}
@@ -1,25 +1,25 @@
----
-abstract: 'Tk - a Graphical User Interface Toolkit'
+--- #YAML:1.0
+name: Tk
+version: 804.032
+abstract: Tk - a Graphical User Interface Toolkit
author:
- - 'nick@ing-simmons.net (Nick Ing-Simmons)'
-build_requires:
- ExtUtils::MakeMaker: 0
+ - nick@ing-simmons.net (Nick Ing-Simmons)
+license: unrestricted
+distribution_type: module
configure_requires:
- ExtUtils::MakeMaker: 0
-dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921'
-license: unrestricted
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Tk
-no_index:
- directory:
- - t
- - inc
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
requires:
- Encode: 0
- Test::More: 0
+ Encode: 0
+ Test::More: 0
resources:
- repository: http://github.com/eserte/perl-tk
-version: 804.031
+ repository: http://github.com/eserte/perl-tk
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.57_05
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
@@ -210,7 +210,7 @@ sub MY::test_via_harness
{
my($self, $perl, $tests) = @_;
qq{\t$perl "-It" "-MTkTest" }.
- qq{"-e" "checked_test_harness('\$(TKDIR)/xt/skip_all.t', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
+ qq{"-e" "checked_test_harness('\$(TKDIR)/xt', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
sub MY::postamble {
@@ -11,44 +11,65 @@ my $zlib = "libz$l";
foreach my $file (qw(zlib/Makefile.PL libpng/Makefile.PL))
{
+ next unless -f $file;
chmod(0666,$file) unless -w $file;
unlink($file);
}
-my $libpng_cflags;
-my $libpng_libs;
-system('pkg-config --exists libpng');
-if ($? == 0) {
- chomp($libpng_cflags = `pkg-config --cflags libpng`);
- chomp($libpng_libs = `pkg-config --libs libpng`);
-} else {
- warn "'pkg-config libpng' failed, continue with fallback values for cflags and libs...\n";
- $libpng_cflags = '-I/usr/local/include';
- $libpng_libs = '-lpng -lz -lm';
+my $all_cflags;
+my $all_libs;
+{
+ my $libpng_cflags;
+ my $libpng_libs;
+ system('pkg-config --exists libpng');
+ if ($? == 0)
+ {
+ chomp($libpng_cflags = `pkg-config --cflags libpng`);
+ chomp($libpng_libs = `pkg-config --libs libpng`);
+ }
+ else
+ {
+ warn "'pkg-config libpng' failed, continue with fallback values for cflags and libs...\n";
+ $libpng_cflags = '-I/usr/local/include';
+ $libpng_libs = '-lpng -lm';
+ }
+
+ my $zlib_cflags;
+ my $zlib_libs;
+ system('pkg-config --exists zlib');
+ if ($? == 0)
+ {
+ chomp($zlib_cflags = `pkg-config --cflags zlib`);
+ chomp($zlib_libs = `pkg-config --libs zlib`);
+ }
+ else
+ {
+ warn "'pkg-config zlib' failed, continue with fallback values for cflags and libs...\n";
+ $zlib_cflags = '-I/usr/local/include';
+ $zlib_libs = '-lz';
+ }
+
+ $all_cflags = "$libpng_cflags $zlib_cflags";
+ $all_libs = "$libpng_libs $zlib_libs";
}
if ($Tk::MMtry::VERSION ge '4.007' &&
- try_run("config/has_png.c",[$libpng_cflags],[$libpng_libs]))
+ try_run("config/has_png.c",[$all_cflags],[$all_libs]))
{
+ warn "Using system's -lpng\n";
Tk::MMutil::TkExtMakefile(
NAME => 'Tk::PNG',
VERSION_FROM => 'PNG.pm',
XS_VERSION => $Tk::Config::VERSION,
dist => { COMPRESS => 'gzip -f9', SUFFIX => '.gz' },
OBJECT => '$(O_FILES)',
- INC => $libpng_cflags,
- LIBS => [$libpng_libs],
+ INC => $all_cflags,
+ LIBS => [$all_libs],
);
}
else
{
my $ok = 1;
- foreach my $file ("libpng/Makefile.PL","zlib/Makefile.PL")
- {
- next unless -f $file;
- chmod(0666,$file);
- unlink($file);
- }
unless (copy("Makefile.libpng.maybe","libpng/Makefile.PL"))
{
warn "Cannot copy Makefile.libpng.maybe => libpng/Makefile.PL ($!)";
@@ -94,7 +115,7 @@ sub MY::test_via_harness
{
my($self, $perl, $tests) = @_;
qq{\t$perl "-I../t" "-MTkTest" }.
- qq{"-e" "checked_test_harness('\$(TKDIR)/xt/skip_all.t', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
+ qq{"-e" "checked_test_harness('\$(TKDIR)/xt', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
package MY;
@@ -5,6 +5,7 @@ use Config;
use File::Copy;
chmod(0666,'Makefile');
+unlink('Makefile');
unless (try_configure())
{
@@ -74,7 +75,7 @@ sub try_configure
|OpenBSD.amd64-openbsd
|i386-freebsd
|x86_64-.* # e.g. linux, dragonfly
- |sun4-solaris
+ |[^-]+-solaris # e.g. sun4-solaris, i86pc-solaris
|IP35-irix
)(?:$|-.*)
}x
@@ -86,8 +87,10 @@ sub try_configure
$ENV{CFLAGS} =~ s{-arch \S+}{}g;
}
system(sh => "./configure");
- open my $fh, ">> Makefile" or die "Can't write to Makefile: $!";
- print $fh <<'EOF';
+ if ($? == 0 && -s "Makefile")
+ {
+ open my $fh, ">>", "Makefile" or die "Can't write to Makefile: $!";
+ print $fh <<'EOF';
libpng.a: all
cp .libs/libpng.a libpng.a
@@ -99,7 +102,12 @@ clean:
test:
EOF
- return 1;
+ return 1;
+ }
+ else
+ {
+ return 0;
+ }
}
return 0;
}
@@ -490,6 +490,24 @@ static int CommonReadPNG(png_ptr, format, imageHandle, destX, destY,
png_set_expand(png_ptr);
}
+#if defined(PNG_sRGB_SUPPORTED) || defined(PNG_gAMA_SUPPORTED)
+#if defined(PNG_sRGB_SUPPORTED)
+ if (png_get_sRGB(png_ptr, info_ptr, &intent)) {
+ png_set_sRGB(png_ptr, info_ptr, intent);
+ } else {
+#endif
+#if defined(PNG_gAMA_SUPPORTED)
+ double gamma;
+ if (!png_get_gAMA(png_ptr, info_ptr, &gamma)) {
+ gamma = 0.45455;
+ }
+ png_set_gamma(png_ptr, 2.2, gamma);
+#endif
+#if defined(PNG_sRGB_SUPPORTED)
+ }
+#endif
+#endif
+
png_read_update_info(png_ptr,info_ptr);
block.pixelSize = png_get_channels(png_ptr, info_ptr);
block.pitch = png_get_rowbytes(png_ptr, info_ptr);
@@ -511,24 +529,6 @@ static int CommonReadPNG(png_ptr, format, imageHandle, destX, destY,
block.offset[3] = 0;
}
-#if defined(PNG_sRGB_SUPPORTED) || defined(PNG_gAMA_SUPPORTED)
-#if defined(PNG_sRGB_SUPPORTED)
- if (png_get_sRGB(png_ptr, info_ptr, &intent)) {
- png_set_sRGB(png_ptr, info_ptr, intent);
- } else {
-#endif
-#if defined(PNG_gAMA_SUPPORTED)
- double gamma;
- if (!png_get_gAMA(png_ptr, info_ptr, &gamma)) {
- gamma = 0.45455;
- }
- png_set_gamma(png_ptr, 1.0, gamma);
-#endif
-#if defined(PNG_sRGB_SUPPORTED)
- }
-#endif
-#endif
-
png_data= (char **) ckalloc(sizeof(char *) * info_height +
info_height * block.pitch);
@@ -50,6 +50,14 @@ fontconfig config file). See also http://fontconfig.org .
To disable this feature run the Makefile.PL
with "perl Makefile.PL XFT=0".
+Note that the default fontconfig configuration may or may not include
+traditional X11 fonts. Please inspect /etc/fonts/fonts.conf or
+/usr/local/etc/fonts/fonts.conf files for the values of the <dir>
+elements. Users may add additional font directories in their
+~/.fonts.conf . See
+http://www.freedesktop.org/software/fontconfig/fontconfig-user.html
+for more information.
+
For questions on this package try news:comp.lang.perl.tk or e-mail to
<ptk@lists.stanford.edu> (needs registration to the mailing list) or
<srezic@cpan.org>
@@ -1,3 +1,41 @@
+Building using ActivePerl and gcc (MinGW)
+
+ActivePerl provides a stripped down MinGW ppm package which can be
+installed using:
+
+ ppm install MinGW
+
+Unfortunately, some binaries required to build Perl/Tk are missing,
+namely: dllwrap, ranlib, and strip (see also
+http://community.activestate.com/node/10487). These binaries have to
+be fetched from elsewhere and copied to C:\Perl\site\bin, where the
+other MinGW binaries reside (gcc, make, ar etc.).
+
+Once done, Perl/Tk can be installed normally using:
+
+ perl Makefile.PL
+ dmake
+ dmake test
+ dmake install
+
+(Tested with ActivePerl 5.16.3 and Tk 804.031_501 using various
+Windows versions)
+
+ActivePerl may also automatically detect MinGW which comes with
+StrawberryPerl. Only $Config{libpth} seems to be wrong and needs to be
+fixed by setting an environment variable:
+
+ set LIBRARY_PATH=C:\strawberry\c\i686-w64-mingw32\lib
+
+After that, Perl/Tk may be built using:
+
+ perl Makefile.PL
+ dmake
+ dmake test
+ dmake install
+
+----------------------------------------------------------------------
+Older notes about building using ActivePerl with Visual C++
Tk800.013 has been built by the author using ActivePerl
from ActiveState's APi509e.exe.
@@ -28,19 +66,3 @@ some versions of VC++ to downgrade "optimization"; from -O2 that
ActivePerl suggests, to -Od. This does not _seem_ to be required this
time.
-----------------------------------------------------------------------
-
-Building using ActivePerl and (Strawberry's) gcc
-
-This is almost straightforward. Only $Config{libpth} seems to be wrong
-and needs to be fixed by setting an environment variable
-
- set LIBRARY_PATH=C:\strawberry\c\i686-w64-mingw32\lib
-
-After that, Tk may be built using
-
- perl Makefile.PL
- dmake
- dmake test
-
-(This was tested with Tk 804.030_502)
@@ -1,30 +1,7 @@
-Tk804.030 should work with a 32bit *standard* Strawberry Perl 5.12.3.0
+Tk804.031_501 should work with 32bit and 64bit standard and portable
+Strawberry Perl 5.18.1.1
The *portable* Strawberry Perl 5.12.3.0 has some problems with the
bundled Config.pm which prevents a successful compilation of Tk. A fix
is proposed in http://rt.cpan.org/Public/Bug/Display.html?id=68937
-Compiling with a 64bit Strawberry Perl works, but some (tix-related)
-tests are failing. See
-https://rt.cpan.org/Public/Bug/Display.html?id=71718
-
-----------------------------------------------------------------------
-Older notes:
-
-Tk804.028_501 should compile out-of-the box with Strawberry Perl
-5.8.8.3 and 5.10.0.3.
-
-Older stuff:
-
-Previous Tk versions do not compile under Windows Vista, possibly
-because of file permission problems.
-
-Strawberry Perl's default CPAN.pm configuration in 5.8.8.2 and
-5.10.0.2 has the setting
-
- makepl_arg [LIBS=-LC:\strawberry\c\lib INC=-IC:\strawberry\c\include]
-
-This breaks the Tk build (and also other CPAN modules). The "fix" is
-to change the setting to the usual default:
-
- o conf makepl_arg ""
@@ -16,10 +16,6 @@ CONFIGURE/BUILD
Use native Win32 GUI calls:
- perl Makefile.PL
-
- or
-
perl Makefile.PL MSWin32
Use X11 client libraries (and requires a X server):
@@ -34,6 +30,10 @@ CONFIGURE/BUILD
perl Makefile.PL x
+ or
+
+ perl Makefile.PL
+
make
TEST
@@ -1,3 +1,67 @@
+System prerequisites for Perl/Tk on Linux
+
+Of course a C compiler (e.g. gcc) and a make tool (e.g. GNU make)
+needs to be installed. Additionally, some libraries and include files
+are required:
+
+Debian, Ubuntu:
+
+The following system packages should be installed:
+
+ libx11-dev (minimal requirement for basic compilation of Perl/Tk)
+ libfreetype6-dev libxft-dev (for freetype support, XFT=1)
+ libpng-dev libz-dev (for using system library for Tk::PNG)
+ libjpeg-dev (for using system library for Tk::JPEG)
+
+CentOS, RedHat, Fedora:
+
+The following system packages should be installed:
+
+ libX11-devel (minimal requirement for basic compilation of Perl/Tk)
+ libXft-devel (for freetype support, XFT=1)
+ libpng-devel zlib-devel (for using system library for Tk::PNG)
+ libjpeg-devel (for using system library for Tk::JPEG)
+
+With all these requirements, building Perl/Tk is straightforward:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+XFT (freetype support) is enabled by default if the system
+prerequisites are met (see above). To explicitely turn it off, use
+
+ perl Makefile.PL XFT=0
+
+It's recommended to install system's libpng, zlib, and libjpeg first.
+Otherwise the bundled (and usually older) versions of libpng, zlib,
+and libjpeg are used.
+
+On some systems the default /etc/fonts/fonts.conf does not include
+traditional X11 fonts by default (seen on a CentOS 6.4 installation,
+probably also the case for the equivalent RedHat version). If you need
+traditional X11 fonts (adobe-courier, adobe-helvetica, adobe-times
+etc.), then there are some options:
+
+* Provide a file /etc/fonts/local.conf with appropriate <dir>
+ elements, e.g.
+
+ <fontconfig>
+ <dir>/usr/share/X11/fonts</dir>
+ </fontconfig>
+
+ This change would be global for all users.
+
+* Create a user-specific configuration file in ~/.fonts.conf with the
+ same content.
+
+* Copy or symlink the directories with the X11 fonts into ~/.fonts
+ (for a user only) or a global font directory like
+ /usr/local/share/fonts.
+
+----------------------------------------------------------------------
+Older instructions follow
These days perl/Tk is developed on Linux so things should work.
Nick uses SuSE Distributions, currently using SuSE 9.0.
@@ -55,11 +119,3 @@ Sometimes when run like:
they will pass :-(
Nick Ing-Simmons 2004/03/18
-
-----------------------------------------------------------------------
-Debian Linux:
-
-The libx11-dev and x-dev packages are necessary to compile Perl/Tk.
-
-The libfreetype6-dev, libxrender-dev and libxft-dev packages are
-necessary to compile with XFT=1.
@@ -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;
@@ -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);
@@ -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;
@@ -71,7 +71,7 @@ $Tk::CHANGE = 'git-controlled';
# is created, $VERSION is checked by bootstrap
$Tk::version = '8.4';
$Tk::patchLevel = '8.4';
-$Tk::VERSION = '804.031';
+$Tk::VERSION = '804.032';
$Tk::VERSION =~ s{_}{};
$Tk::XS_VERSION = $Tk::VERSION;
$Tk::strictMotif = 0;
@@ -1,10 +0,0 @@
-#!/usr/local/bin/perl -w
-use Config;
-my $make = $Config{'make'};
-my @para;
-{local $ENV{'TKNOMAKEDEPEND'} = "1"; system("$^X","Makefile.PL","XFT=1")};
-system($make,"clean");
-system("$^X","Makefile.PL");
-system($make,@ARGV);
-system($make,'test');
-
@@ -0,0 +1,10 @@
+#!/usr/local/bin/perl -w
+use Config;
+my $make = $Config{'make'};
+my @para;
+{local $ENV{'TKNOMAKEDEPEND'} = "1"; system("$^X","Makefile.PL","XFT=1")};
+system($make,"clean");
+system("$^X","Makefile.PL");
+system($make,@ARGV);
+system($make,'test');
+
@@ -234,6 +234,10 @@ if ($] > 5.013002) # SvNV_nomg available
{
$define{'HAS_SVNV_NOMG'} = 1;
}
+if ($] >= 5.009001 || ($] >= 5.008009 && $] < 5.009)) # SvIV_nomg available
+ {
+ $define{'HAS_SVIV_NOMG'} = 1;
+ }
if (!$IsWin32)
{
@@ -404,7 +408,8 @@ EOF
{
warn <<EOF;
You probably need to install the X11 development package first.
-On Debian Linux, these are the packages libx11-dev and x-dev.
+On Debian or Ubuntu, this is the package libx11-dev.
+On CentOS, RedHat, or Fedora, this is the package libX11-devel.
Please see README.linux for more information.
EOF
}
@@ -1400,7 +1400,17 @@ TclObj_get(pTHX_ SV *sv, MAGIC *mg)
static int
TclObj_free(pTHX_ SV *sv, MAGIC *mg)
{
- TclObjMagic_t *info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
+ TclObjMagic_t * info;
+ if (SvTYPE(mg->mg_obj) == SVTYPEMASK)
+ {
+ /* Oops!! Our magic info SV has already been sweeped away
+ * during global destruction. In this case we might leak
+ * some the stuff hanging off the Tcl_InternalRep, but there
+ * are not really much more we can do here.
+ */
+ return 0;
+ }
+ info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
if (info->type)
{
#ifdef DEBUG_TCLOBJ
@@ -1516,7 +1526,11 @@ Tcl_ObjMagic(Tcl_Obj *obj,int add)
iv->type = type;
if (iv->type == &tclIntType)
{
+#ifdef HAS_SVIV_NOMG
iv->internalRep.longValue = SvIV_nomg(obj);
+#else
+ iv->internalRep.longValue = SvIV(obj);
+#endif
}
else if (iv->type == &tclDoubleType)
{
@@ -4,10 +4,6 @@
#define STATIC_BUILD
-#ifdef bool
-#undef bool
-#endif
-
#include "tkConfig.h"
#define TCL_NO_DEPRECATED
@@ -1133,6 +1133,20 @@ Tk_AllocFontFromObj(interp, tkwin, objPtr)
}
}
+ /*
+ * Detect the system font engine going wrong and fail more gracefully.
+ */
+
+ if (fontPtr == NULL) {
+ if (new) {
+ Tcl_DeleteHashEntry(cacheHashPtr);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "failed to allocate font due to internal system font engine"
+ " problem", -1));
+ return NULL;
+ }
+
fontPtr->resourceRefCount = 1;
fontPtr->objRefCount = 1;
fontPtr->cacheHashPtr = cacheHashPtr;
@@ -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
@@ -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
@@ -74,6 +74,11 @@ the widgets which were in the table are destroyed.
The Tk::Table widget is derived from a Tk::Frame, so inherits all its
configure options.
+The default focus traversal is giving the focus only to the table
+widget as a whole. To enable focus traversal into table cells (e.g. if
+there are embedded entry widgets), then the option C<-takefocus> has
+to be set to C<0>.
+
=head1 BUGS / Snags / Possible enhancements
=over 4
@@ -260,6 +260,8 @@ I<imageName>.
This form generates an error if there is no embedded image
by the given name.
+=back
+
If the I<base> could match more than one of the above forms, such
as a I<mark> and I<imageName> both having the same value, then
the form earlier in the above list takes precedence.
@@ -267,6 +269,8 @@ If modifiers follow the base index, each one of them must have one
of the forms listed below. Keywords such as B<chars> and B<wordend>
may be abbreviated as long as the abbreviation is unambiguous.
+=over 4
+
=item B<+ >I<count>B< chars>
Adjust the index forward by I<count> characters, moving to later
@@ -326,14 +330,14 @@ Adjust the index to refer to the character just after the last one of the
word containing the current index. If the current index refers to the last
character of the text then it is not modified.
+=back
+
If more than one modifier is present then they are applied in
left-to-right order. For example, the index ``B<end - 1 chars>''
refers to the next-to-last character in the text and
``B<insert wordstart - 1 c>'' refers to the character just before
the first one in the word containing the insertion cursor.
-=back
-
=head1 TAGS
The first form of annotation in text widgets is a tag.
@@ -10,7 +10,7 @@ Tk::composite - Defining a new composite widget class
package Tk::MyNewWidget;
- use Tk:widgets qw/ list of Tk widgets /;
+ use Tk::widgets qw/ list of Tk widgets /;
use base qw/ Tk::Frame /; # or Tk::Toplevel
Construct Tk::Widget 'MyNewWidget';
@@ -223,7 +223,7 @@ use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT
$NAME = 'ptksh';
$VERSION = '2.03';
$WIN32 = 1 if $^O =~ /Win32/;
-$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
+$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH} . '\\') || 'C:\\' : $ENV{HOME} . "/";
@FONT = ($WIN32 ? (-font => 'systemfixed') : () );
#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
$HISTFILE = "${HOME}.${NAME}_history";
@@ -1,4 +1,4 @@
-# Copyright (C) 2003,2006,2007,2010 Slaven Rezic. All rights reserved.
+# Copyright (C) 2003,2006,2007,2010,2013 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -6,11 +6,11 @@ package TkTest;
use strict;
use vars qw(@EXPORT @EXPORT_OK $eps $VERSION);
-$VERSION = '4.009';
+$VERSION = '4.012';
use base qw(Exporter);
@EXPORT = qw(is_float is_float_pair checked_test_harness);
-@EXPORT_OK = qw(catch_grabs wm_info);
+@EXPORT_OK = qw(catch_grabs wm_info set_have_fixed_font with_fixed_font retry_update create_placeholder_widget);
sub _is_in_path ($);
@@ -18,7 +18,7 @@ use POSIX qw(DBL_EPSILON);
$eps = DBL_EPSILON;
sub checked_test_harness ($@) {
- my($skip_test, @test_harness_args) = @_;
+ my($skip_test_dir, @test_harness_args) = @_;
require ExtUtils::Command::MM;
# In case of cygwin, use'ing Tk before forking (which is done by
@@ -37,9 +37,20 @@ sub checked_test_harness ($@) {
}
if (defined $Tk::platform && $Tk::platform eq 'unix') { # undef for cygwin+MSWin32, because Tk not yet loaded
+ my $skip_all_test;
my $mw = eval { MainWindow->new() };
+ print "# $@\n" if $@;
if (!Tk::Exists($mw)) {
- local @ARGV = $skip_test;
+ $skip_all_test = "skip_all_mw.t";
+ } else {
+ my $l = eval { $mw->Label(-text => "test") }; # will allocate a font, which may fail
+ print "# $@\n" if $@;
+ if (!Tk::Exists($l)) {
+ $skip_all_test = "skip_all_font.t";
+ }
+ }
+ if ($skip_all_test) {
+ local @ARGV = "$skip_test_dir/$skip_all_test";
return ExtUtils::Command::MM::test_harness(@test_harness_args);
}
$mw->destroy;
@@ -197,6 +208,55 @@ sub wm_info ($) {
);
}
+{
+ my $have_fixed_font;
+
+ sub set_have_fixed_font ($) {
+ $have_fixed_font = shift;
+ }
+
+ sub with_fixed_font (&) {
+ my $testcode = shift;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ SKIP:
+ {
+ Test::More::skip("fixed courier font not available", 1) if !$have_fixed_font;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $testcode->();
+ }
+ }
+}
+
+sub retry_update ($) {
+ my($w) = @_;
+
+ my $exposed;
+ $w->bind('<Expose>' => sub { $exposed = 1 });
+ for my $i (1..5) {
+ $w->update;
+ last if ($exposed);
+ my $wait = $i + rand(0.1);
+ Test::More::diag(sprintf("<Expose> event did not arrive, wait for %0.2fs...", $wait));
+ $w->after($wait*1000);
+ }
+ $w->bind('<Expose>' => undef);
+}
+
+# Some WMs are slow when resizing the main window. This may cause test
+# failures, because the test suite does not wait for completion of the
+# WM (and probably cannot do it anyway). To avoid resizing the main
+# window, a placeholder widget is created. This widget has to be
+# re-created every time the main window is re-created, or if all
+# children are destroyed.
+sub create_placeholder_widget ($) {
+ my $mw = shift;
+ my %wm_info = wm_info $mw;
+ my $wm_name = $wm_info{name};
+ if (defined $wm_name && $wm_name =~ m{^( KWin | Fluxbox )$}x) {
+ $mw->Frame(-width => 640, -height => 1)->pack;
+ }
+}
+
# REPO BEGIN
# REPO NAME is_in_path /home/e/eserte/work/srezic-repository
# REPO MD5 e18e6687a056e4a3cbcea4496aaaa1db
@@ -2,7 +2,6 @@
# -*- perl -*-
#
-# $Id: browseentry-subclassing.t,v 1.4 2003/04/21 19:49:27 eserte Exp $
# Author: Slaven Rezic
#
@@ -13,15 +12,15 @@ use Tk::BrowseEntry;
BEGIN {
if (!eval q{
- use Test;
+ use Test::More;
1;
}) {
- print "1..0 # skip: no Test module\n";
+ print "1..0 # skip: no Test::More module\n";
exit;
}
}
-BEGIN { plan tests => 2 }
+BEGIN { plan tests => 3 }
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
@@ -39,7 +38,7 @@ my $ne = $mw->SpinboxBrowseEntry(-from => -10,
-to => +10,
-choices => [-6,-3,0,3,6],
)->pack;
-ok($ne->isa('Tk::SpinboxBrowseEntry'));
+isa_ok $ne, 'Tk::SpinboxBrowseEntry';
{
@@ -69,7 +68,8 @@ ok($ne->isa('Tk::SpinboxBrowseEntry'));
$mw->optionAdd("*MyLabEntryBrowseEntry*Entry.background", "red");
my $le = $mw->MyLabEntryBrowseEntry(-label => "My LabEntry:")->pack;
-ok($le->isa('Tk::MyLabEntryBrowseEntry'));
+isa_ok $le, 'Tk::MyLabEntryBrowseEntry';
+is $le->Subwidget('entry')->Subwidget('entry')->cget('-background'), 'red', 'option db value for subclass';
$top->Button(-text => "Ok",
-command => sub {
@@ -20,7 +20,7 @@ use Tk::Trace;
use Tk::Config ();
my $Xft = $Tk::Config::xlib =~ /-lXft\b/;
-use TkTest qw(wm_info);
+use TkTest qw(set_have_fixed_font with_fixed_font retry_update create_placeholder_widget);
BEGIN {
if (!eval q{
@@ -53,34 +53,7 @@ my $skip_wm_font_test = "window manager and/or font-related tests";
my $mw = Tk::MainWindow->new();
$mw->geometry('+10+10');
-my %wm_info = wm_info($mw);
-my $wm_name = $wm_info{name};
-
-my $kwin_problems = defined $wm_name && $wm_name eq 'KWin';
-my $fluxbox_problems = defined $wm_name && $wm_name eq 'Fluxbox';
-my $metacity_problems = defined $wm_name && $wm_name eq 'Metacity';
-my $xfwm4_problems = defined $wm_name && $wm_name eq 'Xfwm4';
-
-# It seems that scripts using -xscrollcommand have the same problem
-# with wish8.4 (Tcl/Tk 8.4.19)
-sub TODO_xscrollcommand_problem () {
- $TODO = "May fail under some conditions (another grab?) on Metacity" if !$TODO && $metacity_problems;
- $TODO = "May fail under some conditions (another grab?) on xfwm4" if !$TODO && $xfwm4_problems;
-}
-
-# Some WMs are slow when resizing the main window. This may cause test
-# failures, because the test suite does not wait for completion of the
-# WM (and probably cannot do it anyway). To avoid resizing the main
-# window, a placeholder widget is created. This widget has to be
-# re-created every time the main window is re-created, or if all
-# children are destroyed.
-sub create_placeholder_widget () {
- if ($kwin_problems || $fluxbox_problems) {
- $mw->Frame(-width => 640, -height => 1)->pack;
- }
-}
-
-create_placeholder_widget;
+create_placeholder_widget $mw;
my $e0 = $mw->Entry;
ok(Tk::Exists($e0), "Entry widget exists");
@@ -223,6 +196,13 @@ ok(!defined $e);
eval { $e->destroy };
$e = $mw->Entry(-font => $fixed)->pack;
+{
+ # Check if the courier font is really available:
+ require Tk::Font;
+ my %fa = $e->cget(-font)->actual;
+ set_have_fixed_font($fa{'-family'} eq 'Courier' && $fa{'-size'} == -12);
+}
+
$e->update;
my $cx = $mw->fontMeasure($fixed, 'a');
@@ -243,30 +223,32 @@ is_deeply([$e->bbox(0)],[5,5,0,$cy], "Expected bbox");
$e->delete(0,"end");
$e->insert(0,"abc");
-is_deeply([$e->bbox(3)],[5+2*$cx,5,$cx,$cy]);
+with_fixed_font { is_deeply([$e->bbox(3)],[5+2*$cx,5,$cx,$cy]) };
is_deeply([$e->bbox("end")],[$e->bbox(3)]);
$e->delete(0,"end");
$e->insert(0,"ab\x{4e4e}");
-is_deeply([$e->bbox("end")],[5+2*$cx,5,$ux,$cy], "Bbox check with unicode char (at end)");
+with_fixed_font { is_deeply([$e->bbox("end")],[5+2*$cx,5,$ux,$cy], "Bbox check with unicode char (at end)") };
$e->delete(0,"end");
$e->insert(0,"ab\x{4e4e}c");
-is_deeply([$e->bbox(3)],[5+2*$cx+$ux,5,$cx,$cy], "Bbox check with unicode char (before index)");
+with_fixed_font { is_deeply([$e->bbox(3)],[5+2*$cx+$ux,5,$cx,$cy], "Bbox check with unicode char (before index)") };
$e->delete(0,"end");
is_deeply([5,5,0,$cy],[$e->bbox("end")]);
$e->delete(0,"end");
$e->insert(0,"abcdefghij\x{4e4e}klmnop");
-is_deeply([[$e->bbox(0)],
- [$e->bbox(1)],
- [$e->bbox(10)],
- [$e->bbox("end")]],
- [[5,5,$cx,$cy],
- [5+$cx,5,$cx,$cy],
- [5+10*$cx,5,$ux,$cy],
- [5+$ux+15*$cx,5,$cx,$cy]], "More bbox checks with unicode char");
+with_fixed_font {
+ is_deeply([[$e->bbox(0)],
+ [$e->bbox(1)],
+ [$e->bbox(10)],
+ [$e->bbox("end")]],
+ [[5,5,$cx,$cy],
+ [5+$cx,5,$cx,$cy],
+ [5+10*$cx,5,$ux,$cy],
+ [5+$ux+15*$cx,5,$cx,$cy]], "More bbox checks with unicode char")
+};
eval { $e->cget };
like($@, qr/wrong \# args: should be ".* cget option"/, "cget error message");
@@ -410,7 +392,7 @@ $e->insert(end => "This is quite a long string, in fact a ");
$e->insert(end => "very very long string");
$e->scan(qw(mark 30));
$e->scan(qw(dragto 28));
-is($e->index('@0'), 2, "Index of a scrolled string");
+with_fixed_font { is($e->index('@0'), 2, "Index of a scrolled string") };
eval {$e->select };
like($@, qr/Can\'t locate(?: file)? auto\/Tk\/Entry\/select\.al/, "Invalid abbreviated method name (selection)");
@@ -469,7 +451,7 @@ $e->delete(0, "end");
$e->insert("end", "01234567890");
$e->selectionFrom(1);
$e->selection(qw(to 5));
-$e->update;
+#$e->update;
$e->selectionAdjust(4);
is($mw->SelectionGet, "123", "Expected result with selectionGet");
@@ -477,7 +459,7 @@ $e->delete(0, "end");
$e->insert("end", "01234567890");
$e->selectionFrom(1);
$e->selection(qw(to 5));
-$e->update;
+#$e->update;
$e->selectionAdjust(2);
is($mw->SelectionGet, "234");
@@ -515,7 +497,7 @@ eval { $e->selectionTo(2,3) };
like($@, qr/wrong \# args: should be ".* selection to index"/);
$e->xview(5);
-is_deeply([map { substr($_, 0, 8) } $e->xview],["0.053763","0.268817"], "Expected xview result");
+with_fixed_font { is_deeply([map { substr($_, 0, 8) } $e->xview],["0.053763","0.268817"], "Expected xview result") };
eval { $e->xview(qw(gorp)) };
like($@, qr/bad entry index "gorp"/, "xview error message");
@@ -523,7 +505,7 @@ like($@, qr/bad entry index "gorp"/, "xview error message");
$e->xview(0);
$e->icursor(10);
$e->xview('insert');
-is_deeply([map { substr($_, 0, 7) } $e->xview],["0.10752","0.32258"]);
+with_fixed_font { is_deeply([map { substr($_, 0, 7) } $e->xview],["0.10752","0.32258"]) };
eval { $e->xviewMoveto(qw(foo bar)) };
like($@, qr/wrong \# args: should be ".* xview moveto fraction"/);
@@ -532,7 +514,7 @@ eval { $e->xview(qw(moveto foo)) };
like($@, qr/\'foo\' isn\'t numeric/);
$e->xviewMoveto(0.5);
-is_deeply([map { substr($_, 0, 7) } $e->xview],["0.50537","0.72043"]);
+with_fixed_font { is_deeply([map { substr($_, 0, 7) } $e->xview],["0.50537","0.72043"]) };
eval { $e->xviewScroll(24) };
like($@, qr/wrong \# args: should be ".* xview scroll number units\|pages"/, "xviewScroll error message");
@@ -542,12 +524,12 @@ like($@, qr/\'gorp\' isn\'t numeric/);
$e->xviewMoveto(0);
$e->xview(qw(scroll 1 pages));
-is_deeply([map { substr($_, 0, 7) } $e->xview],["0.19354","0.40860"]);
+with_fixed_font { is_deeply([map { substr($_, 0, 7) } $e->xview],["0.19354","0.40860"]) };
$e->xview(qw(moveto .9));
$e->update;
$e->xview(qw(scroll -2 p));
-is_deeply([map { substr($_, 0, 7) } $e->xview],["0.39784","0.61290"]);
+with_fixed_font { is_deeply([map { substr($_, 0, 7) } $e->xview],["0.39784","0.61290"]) };
$e->xview(30);
$e->update;
@@ -571,7 +553,7 @@ $e->xview(-4);
is($e->index('@0'), 0);
$e->xview(300);
-is($e->index('@0'), 73);
+with_fixed_font { is($e->index('@0'), 73) };
{
$e->insert(10, "\x{4e4e}");
@@ -673,15 +655,9 @@ is($e->index("sel.last"), 5);
eval { $e->destroy };
$e = $mw->Entry(-font => $fixed, qw(-width 4 -xscrollcommand), \&scroll)->pack;
$e->insert(qw(end 01234567890));
-$e->update;
+retry_update $e;
$e->configure(qw(-width 5));
-if (!do {
- local $TODO;
- TODO_xscrollcommand_problem;
- is_deeply([map { substr($_, 0, 8) } @scrollInfo], [0,0.363636]);
-}) {
- diag "Scrollinfo not as expected (after insert): <@scrollInfo>"
-}
+is_deeply([map { substr($_, 0, 8) } @scrollInfo], [0,0.363636]);
eval { $e->destroy };
@@ -701,7 +677,7 @@ $e = $mw->Entry(-font => $fixed, -bd => 2, -relief => "raised")->pack;
$e->insert(end => "0123");
$e->update;
is($e->index('@10'), 0, "index with raised relief");
-is($e->index('@11'), 0);
+with_fixed_font { is($e->index('@11'), 0) };
is($e->index('@12'), 1);
is($e->index('@13'), 1);
@@ -710,7 +686,7 @@ $e = $mw->Entry(-font => $fixed, -bd => 2, -relief => "flat")->pack;
$e->insert(end => "0123");
$e->update;
is($e->index('@10'), 0, "index with flat relief");
-is($e->index('@11'), 0);
+with_fixed_font { is($e->index('@11'), 0) };
is($e->index('@12'), 1);
is($e->index('@13'), 1);
@@ -727,22 +703,22 @@ eval { $e->destroy };
$e = $mw->Entry(-font => $fixed, -bd => 2, -relief => "raised", -width => 20, -highlightthickness => 3)->pack;
$e->insert("end", "012\t45");
$e->update;
-is($e->index('@61'), 3, "index with highlightthickness");
-is($e->index('@62'), 4);
+with_fixed_font { is($e->index('@61'), 3, "index with highlightthickness") };
+with_fixed_font { is($e->index('@62'), 4) };
eval { $e->destroy };
$e = $mw->Entry(-font => $fixed, qw(-bd 2 -relief raised -width 20 -justify center -highlightthickness 3))->pack;
$e->insert("end", "012\t45");
$e->update;
-is($e->index('@96'), 3, "index with center justify");
-is($e->index('@97'), 4);
+with_fixed_font { is($e->index('@96'), 3, "index with center justify") };
+with_fixed_font { is($e->index('@97'), 4) };
eval { $e->destroy };
$e = $mw->Entry(-font => $fixed, qw(-bd 2 -relief raised -width 20 -justify right -highlightthickness 3))->pack;
$e->insert("end", "012\t45");
$e->update;
-is($e->index('@131'), 3, "index with right justify");
-is($e->index('@132'), 4);
+with_fixed_font { is($e->index('@131'), 3, "index with right justify") };
+with_fixed_font { is($e->index('@132'), 4) };
eval { $e->destroy };
$e = $mw->Entry(-font => $fixed, qw(-bd 2 -relief raised -width 5))->pack;
@@ -763,7 +739,7 @@ $e = $mw->Entry(-font => $fixed, qw(-bd 2 -relief raised -width 10))->pack;
$e->insert(qw(end), "01234\t67890");
$e->update;
$e->xview(3);
-is($e->index('@39'), 5, "index with tabulator in entry");
+with_fixed_font { is($e->index('@39'), 5, "index with tabulator in entry") };
is($e->index('@40'), 6);
SKIP: {
@@ -820,16 +796,10 @@ $e->focus;
$e->delete(0, "end");
$e->insert(0, "abcde");
$e->insert(2, "XXX");
-$e->update;
+retry_update $e;
is($e->get, "abXXXcde");
is($contents, "abXXXcde");
-if (!do {
- local $TODO;
- TODO_xscrollcommand_problem;
- is(join(" ", @scrollInfo), "0 1", "Result collected in -xscrollcommand callback");
-}) {
- diag "Scrollinfo not as expected (after delete/insert): <@scrollInfo>";
-}
+is(join(" ", @scrollInfo), "0 1", "Result collected in -xscrollcommand callback");
$e->delete(0, "end");
$e->insert(0, "abcde");
@@ -947,7 +917,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 3));
$e->selection(qw(to 8));
$e->delete(qw(1 3));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 1);
is($e->index("sel.last"), 6);
$e->selectionTo(5);
@@ -959,7 +929,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 3));
$e->selection(qw(to 8));
$e->delete(qw(1 4));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 1);
is($e->index("sel.last"), 5);
$e->selectionTo(4);
@@ -971,7 +941,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 3));
$e->selection(qw(to 8));
$e->delete(qw(1 7));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 1);
is($e->index("sel.last"), 2);
$e->selectionTo(5);
@@ -991,7 +961,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 3));
$e->selection(qw(to 8));
$e->delete(qw(3 7));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 3);
is($e->index("sel.last"), 4);
$e->selectionTo(8);
@@ -1011,7 +981,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 8));
$e->selection(qw(to 3));
$e->delete(qw(5 8));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 3);
is($e->index("sel.last"), 5);
$e->selectionTo(8);
@@ -1023,7 +993,7 @@ $e->insert(qw(0 0123456789abcde));
$e->selection(qw(from 8));
$e->selection(qw(to 3));
$e->delete(qw(8 10));
-$e->update;
+#$e->update;
is($e->index("sel.first"), 3);
is($e->index("sel.last"), 8);
$e->selectionTo(4);
@@ -1072,7 +1042,7 @@ $e->delete(qw(0 end));
$e->insert(0, "xyzzy");
$e->update;
$e->delete(qw(2 4));
-is($e->reqwidth, 31);
+with_fixed_font { is($e->reqwidth, 31) };
eval { $e->destroy };
@@ -1172,7 +1142,7 @@ my $e1 = $mw->Entry(-fg => '#112233');
is(($mw->children)[0], $e1);
$e1->destroy;
is(scalar($mw->children), undef); # XXX why not 0?
-create_placeholder_widget;
+create_placeholder_widget $mw;
$e = $mw->Entry(-font => $fixed, qw(-width 5 -bd 2 -relief sunken))->pack;
$e->insert(qw(0 012345678901234567890));
@@ -1241,7 +1211,7 @@ eval { $e->index('@xyz') };
like($@, qr/bad entry index "\@xyz"/);
is($e->index('@4'), 4);
-is($e->index('@11'), 4);
+with_fixed_font { is($e->index('@11'), 4) };
is($e->index('@12'), 5);
is($e->index('@' . ($e->width-6)), 8);
is($e->index('@' . ($e->width-5)), 9);
@@ -1377,15 +1347,9 @@ Tk::catch {$e->destroy};
eval {
local *Tk::Error = sub { $err = $_[1] };
$e = $mw->Entry(qw(-width 5 -xscrollcommand thisisnotacommand))->pack;
- $e->update;
+ retry_update $e;
};
- if (!do {
- local $TODO;
- TODO_xscrollcommand_problem;
- like($err, qr/Undefined subroutine &main::thisisnotacommand/, "Expected invalid -xscrollcommand callback");;
- }) {
- diag "Undefined subroutine thisisnotacommand not detected";
- }
+ like($err, qr/Undefined subroutine &.*::thisisnotacommand/, "Expected invalid -xscrollcommand callback");;
$e->destroy;
}
@@ -1398,17 +1362,13 @@ Tk::catch {$e->destroy};
eval {
local *Tk::Error = sub { $err = $_[1] };
$e = $mw->Entry(qw(-width 5))->pack;
- $e->update;
+ retry_update $e;
$e->configure(qw(-xscrollcommand thisisnotacommand));
$e->insert("end", "more than 5 chars");
$e->xviewMoveto(1); # should really scroll
$e->update;
};
- {
- local $TODO;
- TODO_xscrollcommand_problem;
- like($err, qr/Undefined subroutine &main::thisisnotacommand/, "Expected invalid -xscrollcommand callback");
- }
+ like($err, qr/Undefined subroutine &main::thisisnotacommand/, "Expected invalid -xscrollcommand callback");
$e->destroy;
}
@@ -43,6 +43,12 @@ $mw->after(100, sub {
second_error();
});
+$mw->after(20*1000, sub {
+ if (Tk::Exists($mw)) {
+ $mw->destroy;
+ fail "Timeout - destroyed main window";
+ }
+ });
MainLoop;
sub second_error {
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Tk;
+
+BEGIN {
+ if (!eval q{
+ use Test::More;
+ 1;
+ }) {
+ print "1..0 # skip: no Test::More module\n";
+ exit;
+ }
+}
+
+plan tests => 2;
+
+sub main {
+ my $mw = MainWindow->new;
+ $mw->geometry('+10+10');
+ my $w = $mw->Label(-text => 'bob');
+ $w->bind('<ButtonPress-1>' => \&bump_flag);
+
+ event_test($w, 1);
+ my $junk = $w->id; # vivify the widget XID, by provoking Tk_MakeWindowExist
+ event_test($w, 0);
+}
+
+my $flag;
+sub bump_flag {
+ $flag ++;
+
+ return;
+}
+
+sub event_test {
+ my ($w, $early) = @_;
+ $flag = 0;
+ my $got = do {
+ $w->eventGenerate('<ButtonPress-1>');
+ "flag=$flag";
+ };
+
+ if ($early) {
+ is($got, 'flag=0', 'early event is ineffective');
+ } else {
+ is($got, 'flag=1', 'late event should bump_flag');
+ }
+
+ return;
+}
+
+
+main();
@@ -30,7 +30,7 @@ eval { $top->geometry('+10+10'); }; # This works for mwm and interactivePlacemen
my $f;
-my $delay = 500;
+my $delay = 250;
GetOptions("delay=i" => \$delay)
or die "usage: $0 [-delay ...ms]";
@@ -58,7 +58,7 @@ eval {
is($@, "", "creating Tk::FBox widget");
catch_grabs {
- $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
+ destroy_if_visible($f) if $ENV{BATCH};
my $result = $f->Show;
if (!$ENV{BATCH}) {
diag "Result is <$result>";
@@ -81,7 +81,7 @@ eval {
is($@, "", "creating Tk::FBox widget");
catch_grabs {
- $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
+ destroy_if_visible($f) if $ENV{BATCH};
my $result = $f->Show;
if (!$ENV{BATCH}) {
diag "Result is <$result>";
@@ -112,7 +112,7 @@ eval {
is($@, "", "creating Tk::FBox widget for save");
catch_grabs {
- $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
+ destroy_if_visible($f) if $ENV{BATCH};
my $result = $f->Show;
if (!$ENV{BATCH}) {
diag "Result is <$result>";
@@ -132,7 +132,7 @@ eval {
is($@, "", "creating Tk::FBox widget for choosing directories");
catch_grabs {
- $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
+ destroy_if_visible($f) if $ENV{BATCH};
my $result = $f->Show;
if (!$ENV{BATCH}) {
diag "Result is <$result>";
@@ -195,5 +195,41 @@ TODO: {
};
}
+# Tk::FBox is internally using waitVisibility. The test may however
+# try to destroy the window before the visibility ever changed,
+# leading to errors like
+#
+# window ".fbox" was deleted before its visibility changed
+#
+# To prevent this, the <Visibility> events are trapped. If there
+# was no such event when the window is about to be destroyed,
+# then the script waits another second, up to a maximum of
+# 10 seconds.
+sub destroy_if_visible {
+ my $w = shift;
+ my $visibility_changed = 0;
+ $w->bind('<Visibility>' => sub { $visibility_changed = 1 });
+ my $trials = 0;
+ my $destroy_if_visibility_changed;
+ $destroy_if_visibility_changed =
+ sub {
+ if ($visibility_changed) {
+ $w->destroy;
+ } else {
+ $trials++;
+ if ($trials > 10) {
+ diag "Window never got visible, destroying nevertheless...";
+ $w->destroy;
+ } else {
+ if ($trials == 1) {
+ diag "Slow delivery of <Visibility> event, waiting...";
+ }
+ $w->after(1000, $destroy_if_visibility_changed);
+ }
+ }
+ };
+ $w->after($delay, $destroy_if_visibility_changed);
+}
+
1;
__END__
@@ -23,7 +23,7 @@ my $Xft = $Tk::Config::xlib =~ /-lXft\b/;
use FindBin;
use lib "$FindBin::RealBin";
-use TkTest qw(is_float wm_info);
+use TkTest qw(is_float wm_info set_have_fixed_font with_fixed_font);
use Getopt::Long;
@@ -71,17 +71,30 @@ ok(Tk::Exists($mw));
my %wm_info = wm_info($mw);
my $wm_name = $wm_info{name};
-my $kwin_problems = defined $wm_name && $wm_name eq 'KWin';
+#my $kwin_problems = defined $wm_name && $wm_name eq 'KWin';
my $fluxbox_problems = defined $wm_name && $wm_name eq 'Fluxbox';
-my $metacity_problems = defined $wm_name && $wm_name eq 'Metacity';
-my $xfwm4_problems = defined $wm_name && $wm_name eq 'Xfwm4';
+#my $metacity_problems = defined $wm_name && $wm_name eq 'Metacity';
+#my $xfwm4_problems = defined $wm_name && $wm_name eq 'Xfwm4';
# This is probably the same problem as in t/entry.t
-sub TODO_xscrollcommand_problem () {
- $TODO = "May fail under some conditions (another grab?) on KDE" if !$TODO && $kwin_problems;
- $TODO = "May fail under some conditions (another grab?) on Metacity" if !$TODO && $metacity_problems;
- $TODO = "May fail under some conditions (another grab?) on Fluxbox" if !$TODO && $fluxbox_problems;
- $TODO = "May fail under some conditions (another grab?) on xfwm4" if !$TODO && $xfwm4_problems;
+sub TODO_xscrollcommand_problem (&) {
+ my $code = shift;
+ local $TODO;
+ #$TODO = "May fail under some conditions (another grab?) on KDE" if !$TODO && $kwin_problems;
+ #$TODO = "May fail under some conditions (another grab?) on Metacity" if !$TODO && $metacity_problems;
+ #$TODO = "May fail under some conditions (another grab?) on Fluxbox" if !$TODO && $fluxbox_problems;
+ #$TODO = "May fail under some conditions (another grab?) on xfwm4" if !$TODO && $xfwm4_problems;
+ $TODO = "May fail under some conditions" if $Tk::platform eq 'unix'; # may happen even on fvwm on heavy load
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ $code->();
+}
+
+sub TODO_fluxbox_problem (&) {
+ my $code = shift;
+ local $TODO;
+ $TODO = "May fail under some conditions on Fluxbox" if !$TODO && $fluxbox_problems;
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ $code->();
}
# Create entries in the option database to be sure that geometry options
@@ -124,7 +137,6 @@ my $skip_font_test;
}
}
-my $skip_fixed_font_test;
{
my $fixed_lb = $mw->$Listbox(-font => $fixed);
my %fa = ($mw->fontActual($fixed_lb->cget(-font)),
@@ -141,13 +153,15 @@ my $skip_fixed_font_test;
"-linespace" => 13,
"-fixed" => 1,
);
+ my $have_fixed_font = 1;
while(my($key,$val) = each %expected) {
if (lc $val ne lc $fa{$key}) {
diag "Value $key does not match: got $fa{$key}, expected $val\n" if $v;
- $skip_fixed_font_test = "font-related tests (fixed font not std courier)";
+ $have_fixed_font = 0;
last;
}
}
+ set_have_fixed_font($have_fixed_font);
$fixed_lb->destroy;
}
@@ -738,7 +752,9 @@ is($lb->index('@0,0'), 13);
mkPartial();
$partial_lb->see(4);
-is($partial_lb->index('@0,0'), 1);
+TODO_fluxbox_problem {
+ is($partial_lb->index('@0,0'), 1);
+};
eval { $lb->selection };
like($@ ,qr/wrong \# args: should be \"\.listbox.* selection option index \?index\?\"/,
@@ -862,7 +878,7 @@ SKIP: {
if $Listbox eq 'TextList';
$lb->xview(4);
- is_float(join(",",$lb->xview), "0.08,0.28", "Listbox xview with floats");
+ with_fixed_font { is_float(join(",",$lb->xview), "0.08,0.28", "Listbox xview with floats") };
}
eval { $lb->xview("foo") };
@@ -879,25 +895,25 @@ SKIP: {
$lb->xview(0);
$lb->xview(moveto => 0.4);
$lb->update;
- is_float(($lb->xview)[0], 0.4);
- is_float(($lb->xview)[1], 0.6);
+ with_fixed_font { is_float(($lb->xview)[0], 0.4) };
+ with_fixed_font { is_float(($lb->xview)[1], 0.6) };
$lb->xview(0);
$lb->xview(scroll => 2, "units");
$lb->update;
- is_float("@{[ $lb->xview ]}", '0.04 0.24');
+ with_fixed_font { is_float("@{[ $lb->xview ]}", '0.04 0.24') };
$lb->xview(30);
$lb->xview(scroll => -1, "pages");
$lb->update;
- is_float("@{[ $lb->xview ]}", '0.44 0.64');
+ with_fixed_font { is_float("@{[ $lb->xview ]}", '0.44 0.64') };
$lb->configure(-width => 1);
$lb->update;
$lb->xview(30);
$lb->xview("scroll", -4, "pages");
$lb->update;
- is_float("@{[ $lb->xview ]}", '0.52 0.54');
+ with_fixed_font { is_float("@{[ $lb->xview ]}", '0.52 0.54') };
}
eval { $lb->destroy };
@@ -1181,19 +1197,17 @@ SKIP: {
Tk::catch { $lb->destroy if Tk::Exists($lb) };
$lb = $mw->$Listbox(-font => $fixed, -width => 15, -height => 20)->pack;
-SKIP: {
- skip($skip_fixed_font_test, 2) if $skip_fixed_font_test;
- is($lb->reqwidth, 115, "Reqwidth with fixed font");
- is($lb->reqheight, 328, "Reqheight with fixed font");
+{
+ with_fixed_font { is($lb->reqwidth, 115, "Reqwidth with fixed font") };
+ with_fixed_font { is($lb->reqheight, 328, "Reqheight with fixed font") };
}
eval { $lb->destroy };
$lb = $mw->$Listbox(-font => $fixed, -width => 0, -height => 10)->pack;
$lb->update;
-SKIP: {
- skip($skip_fixed_font_test, 2) if $skip_fixed_font_test;
- is($lb->reqwidth, 17);
- is($lb->reqheight, 168);
+{
+ with_fixed_font { is($lb->reqwidth, 17) };
+ with_fixed_font { is($lb->reqheight, 168) };
}
eval { $lb->destroy };
@@ -1201,20 +1215,18 @@ $lb = $mw->$Listbox(-font => $fixed, -width => 0, -height => 10,
-bd => 3)->pack;
$lb->insert(0, "Short", "Really much longer", "Longer");
$lb->update;
-SKIP: {
- skip($skip_fixed_font_test, 2) if $skip_fixed_font_test;
- is($lb->reqwidth, 138);
- is($lb->reqheight, 170);
+{
+ with_fixed_font { is($lb->reqwidth, 138) };
+ with_fixed_font { is($lb->reqheight, 170) };
}
eval { $lb->destroy };
$lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 0,
)->pack;
$lb->update;
-SKIP: {
- skip($skip_fixed_font_test, 2) if $skip_fixed_font_test;
- is($lb->reqwidth, 80);
- is($lb->reqheight, 24);
+{
+ with_fixed_font { is($lb->reqwidth, 80) };
+ with_fixed_font { is($lb->reqheight, 24) };
}
eval { $lb->destroy };
@@ -1222,10 +1234,9 @@ $lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 0,
-highlightthickness => 0)->pack;
$lb->insert(0, "Short", "Really much longer", "Longer");
$lb->update;
-SKIP: {
- skip($skip_fixed_font_test, 2) if $skip_fixed_font_test;
- is($lb->reqwidth, 76);
- is($lb->reqheight, 52);
+{
+ with_fixed_font { is($lb->reqwidth, 76) };
+ with_fixed_font { is($lb->reqheight, 52) };
}
eval { $lb->destroy };
@@ -1682,23 +1693,23 @@ $lb->update;
@log = ();
$lb->xview(qw/99/);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.9 1");
-is_float(($lb->xview)[0], 0.9);
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.9 1") };
+with_fixed_font { is_float(($lb->xview)[0], 0.9) };
is(($lb->xview)[1], 1);
-is_float($log[0], "x 0.9 1");
+with_fixed_font { is_float($log[0], "x 0.9 1") };
@log = ();
$lb->xview(qw/moveto -.25/);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0 0.1");
-is_float($log[0], "x 0 0.1");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0 0.1") };
+with_fixed_font { is_float($log[0], "x 0 0.1") };
$lb->xview(qw/10/);
$lb->update;
@log = ();
$lb->xview(qw/10/);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.1 0.2");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.1 0.2") };
is(scalar @log, 0);
$lb->destroy;
@@ -1714,7 +1725,7 @@ $lb->xview(qw/0/);
$lb->scan(qw/mark 10 20/);
$lb->scan(qw/dragto/, 10-$width, 20-$height);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.2 0.4");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.2 0.4") };
is_float("@{[ $lb->yview ]}", "0.5 0.75");
$lb->yview(qw/5/);
@@ -1722,13 +1733,13 @@ $lb->xview(qw/10/);
$lb->scan(qw/mark 10 20/);
$lb->scan(qw/dragto 20 40/);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0 0.2");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0 0.2") };
is_float("@{[ $lb->yview ]}", "0 0.25");
$lb->scan(qw/dragto/, 20-$width, 40-$height);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.2 0.4");
-is_float(join(',',$lb->xview), "0.2,0.4"); # just to prove it is a list
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.2 0.4") };
+with_fixed_font { is_float(join(',',$lb->xview), "0.2,0.4") }; # just to prove it is a list
is_float("@{[ $lb->yview ]}", "0.5 0.75");
is_float(join(',',$lb->yview), "0.5,0.75"); # just to prove it is a list
@@ -1737,11 +1748,11 @@ $lb->xview(qw/moveto 1.0/);
$lb->scan(qw/mark 10 20/);
$lb->scan(qw/dragto 5 10/);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.8 1");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.8 1") };
is_float("@{[ $lb->yview ]}", "0.75 1");
$lb->scan(qw/dragto/, 5+$width, 10+$height);
$lb->update;
-is_float("@{[ $lb->xview ]}", "0.64 0.84");
+with_fixed_font { is_float("@{[ $lb->xview ]}", "0.64 0.84") };
is_float("@{[ $lb->yview ]}", "0.25 0.5");
mkPartial();
@@ -1756,12 +1767,10 @@ $lb->yview(qw/4/);
$lb->pack;
$lb->update;
-SKIP: {
- skip($skip_fixed_font_test, 3) if $skip_fixed_font_test;
-
- is($lb->index(q/@50,0/), 4);
- is($lb->index(q/@50,35/), 5);
- is($lb->index(q/@50,36/), 6);
+{
+ with_fixed_font { is($lb->index(q/@50,0/), 4) };
+ with_fixed_font { is($lb->index(q/@50,35/), 5) };
+ with_fixed_font { is($lb->index(q/@50,36/), 6) };
}
like($lb->index(q/@50,200/), qr/^\d+/);
@@ -1887,8 +1896,10 @@ $lb->update;
$lb->delete(qw/0 end/);
$lb->update;
is($log[0], "y 0 1");
-is_float($log[1], "y 0 0.625");
-is($log[2], "y 0 1");
+TODO_fluxbox_problem {
+ is_float($log[1], "y 0 0.625");
+ is($log[2], "y 0 1");
+};
mkPartial();
$partial_lb->configure(-yscrollcommand => ["record", "y"]);
@@ -1922,7 +1933,7 @@ $lb->update;
$lb->delete(qw/0 end/);
$lb->update;
is($log[0], "x 0 1");
-like($log[1] ,qr/^x 0 0\.32258/);
+with_fixed_font { like($log[1] ,qr/^x 0 0\.32258/) };
is($log[2], "x 0 1");
@x = ();
@@ -2116,13 +2127,9 @@ $lb->insert("end", "0000000000");
$mw->update;
$lb->insert("end", "00000000000000000000");
$mw->update;
-if (!do {
- local $TODO;
- TODO_xscrollcommand_problem;
+TODO_xscrollcommand_problem {
is_deeply(\@log, ["x 0 1", "x 0 1", "x 0 0.5"]);
-}) {
- diag "Scrollinfo not as expected (after double insert): <" . join(";", @log) . ">";
-}
+};
SKIP: {
skip("no itemconfigure in Tk800.x", 35)
@@ -2314,9 +2321,19 @@ sub resetGridInfo {
# can cause all sorts of problems. The "wm positionfrom" command is
# needed so that the window manager doesn't ask the user to
# manually position the window when it is re-mapped.
- $mw->withdraw;
- $mw->positionfrom('user');
- $mw->deiconify;
+ #
+ # On the other hand, calling these lines seem to cause strange
+ # test failures with almost all window managers. The same lines of
+ # code in Tcl/Tk seem also to be problematic. So run these lines only
+ # for mwm
+ if (eval {
+ require Tk::Mwm;
+ $mw->mwm('ismwmrunning');
+ }) {
+ $mw->withdraw;
+ $mw->positionfrom('user');
+ $mw->deiconify;
+ }
}
# Procedure that creates a second listbox for checking things related
@@ -5,7 +5,7 @@ use Test;
BEGIN
{
- plan test => 24;
+ plan test => 25;
};
eval { require Tk };
@@ -68,6 +68,9 @@ ok($opt2menu->entrycget("last", -label), "Label 20", "wrong label");
ok($ {$opt2->cget(-textvariable)}, "Label $foo2", "wrong label");
+eval { $opt->eventGenerate('<<MenuSelect>>') };
+ok($@, "", "problem sending a MenuSelect event");
+
#Tk::MainLoop();
1;
@@ -1,14 +1,20 @@
BEGIN { $^W = 1; $| = 1;}
use strict;
+use FindBin;
+use lib $FindBin::RealBin;
use Test::More;
use Tk;
use Tk::widgets qw(ProgressBar);
+use TkTest qw(create_placeholder_widget);
+
plan tests => 27;
my $mw = MainWindow->new();
$mw->geometry('+100+100');
+create_placeholder_widget $mw;
+
my $var = 0;
my $pb = $mw->ProgressBar(-bd => 3, -relief => 'raised', -fg => 'blue', -variable => \$var)->pack;
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+# -*- cperl -*-
+
+#
+# Author: Slaven Rezic
+#
+
+use strict;
+use Test::More 'no_plan';
+use Tk;
+
+my $mw = tkinit;
+$mw->geometry('+0+0');
+
+{
+ # a couple of test cases related to RT #90077
+ {
+ my $val = 0.20;
+ { no warnings 'void'; $val * 2 }
+ is $val * 1, 0.20;
+
+ {
+ my $e = $mw->Entry(-textvariable => \$val)->pack;
+ $e->destroy;
+ }
+ # This fails with perl < 5.18
+ is $val * 1, 0.20 or
+ do { require Devel::Peek; Devel::Peek::Dump($val) }; # pv_dump says: FLAGS = (PADMY,IOK,NOK,POK,pIOK,pNOK,pPOK,UTF8)
+ }
+
+ {
+ my $val = 0.20;
+ { no warnings 'void'; $val * 2 }
+ is $val * 1, 0.20;
+
+ {
+ my $e = $mw->Entry(-textvariable => \$val)->pack;
+ { no warnings 'void'; $val * 2 } # set the pIOK flag again
+ $e->destroy;
+ }
+ # This fails also with perl 5.18
+ is $val * 1, 0.20 or
+ do { require Devel::Peek; Devel::Peek::Dump($val) };
+ }
+}
+
+__END__
@@ -14,10 +14,14 @@
# Translated to Perl/Tk by Slaven Rezic
use strict;
+use FindBin;
+use lib $FindBin::RealBin;
no warnings 'qw';
use Tk;
+use TkTest qw(set_have_fixed_font with_fixed_font);
+
BEGIN {
if (!eval q{
use Test::More;
@@ -63,7 +67,6 @@ $t->pack(qw(-expand 1 -fill both));
$t->update;
$t->debug("on");
-my $skip_fixed_font_test;
{
my $font = $t->cget(-font);
my %fa = ($mw->fontActual($font),
@@ -80,13 +83,15 @@ my $skip_fixed_font_test;
"-linespace" => 13,
"-fixed" => 1,
);
+ my $have_fixed_font = 1;
while(my($key,$val) = each %expected) {
if (lc $val ne lc $fa{$key}) {
diag "Value $key does not match: got $fa{$key}, expected $val\n" if $v;
- $skip_fixed_font_test = "font-related tests (fixed font not std courier)";
+ $have_fixed_font = 0;
last;
}
}
+ set_have_fixed_font($have_fixed_font);
}
# The statements below reset the main window; it's needed if the window
@@ -1141,8 +1146,7 @@ $t->configure(-state => "normal");
eval { $mw->SelectionGet };
like($@, qr{\QPRIMARY selection doesn't exist or form "STRING" not defined});
}
-SKIP: {
- skip($skip_fixed_font_test, 1) if $skip_fixed_font_test;
+{
# This test is non-portable because the window size will vary depending
# on the font size, which can vary.
$t2->destroy if Tk::Exists($t2);
@@ -1156,7 +1160,7 @@ SKIP: {
## wm the test would fail, so check only the width and height
## portions of the geometry.
# is($t2->geometry, q{150x140+0+0}); # the original test as in Tcl/Tk
- like($t2->geometry, qr{^150x140\+}, "Toplevel width and height expected for given -width/-height");
+ with_fixed_font { like($t2->geometry, qr{^150x140\+}, "Toplevel width and height expected for given -width/-height") };
}
{
# This test was failing Windows because the title bar on .t2
@@ -1192,20 +1196,20 @@ SKIP: {
$t2->update;
is($t2->geometry, q{15x8+0+0});
}
-SKIP: {
- skip($skip_fixed_font_test, 4) if $skip_fixed_font_test;
-
+{
$t2->destroy if Tk::Exists($t2);
$t2 = $mw->Text(qw(-width 20 -height 10));
- is($t2->reqheight, 140,
- q{TextWorldChanged procedure, spacing options}
- );
+ with_fixed_font {
+ is($t2->reqheight, 140,
+ q{TextWorldChanged procedure, spacing options}
+ );
+ };
$t2->configure(-spacing1 => 2);
- is($t2->reqheight, 160);
+ with_fixed_font { is($t2->reqheight, 160) };
$t2->configure(-spacing3 => 1);
- is($t2->reqheight, 170);
+ with_fixed_font { is($t2->reqheight, 170) };
$t2->configure(-spacing1 => 0);
- is($t2->reqheight, 150);
+ with_fixed_font { is($t2->reqheight, 150) };
}
# (Skipped tests text-15.* because of non-existing "rename" in Perl/Tk
@@ -1250,8 +1254,10 @@ SKIP: {
$t2->see('end');
$mw->update;
$t2->insert('1.0' => "Short\n");
- is($t2->index('@0,0'), '2.56',
- q{InsertChars procedure, inserting on top visible line});
+ with_fixed_font {
+ is($t2->index('@0,0'), '2.56',
+ q{InsertChars procedure, inserting on top visible line});
+ };
}
{
@@ -1263,7 +1269,7 @@ SKIP: {
$t2->see('end');
$mw->update;
$t2->insert('1.55' => "Short\n");
- is($t2->index('@0,0'), '2.0');
+ with_fixed_font { is($t2->index('@0,0'), '2.0') };
}
{
@@ -1275,7 +1281,7 @@ SKIP: {
$t2->see('end');
$mw->update;
$t2->insert('1.56' => "Short\n");
- is($t2->index('@0,0'), '1.56');
+ with_fixed_font { is($t2->index('@0,0'), '1.56') };
}
{
@@ -1287,7 +1293,7 @@ SKIP: {
$t2->see('end');
$mw->update;
$t2->insert('1.57' => "Short\n");
- is($t2->index('@0,0'), '1.56');
+ with_fixed_font { is($t2->index('@0,0'), '1.56') };
}
$t2->destroy if Tk::Exists($t2);
@@ -1451,8 +1457,10 @@ Line 4
$t2t->insert('end', "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n");
$t2t->yview(qw(2.4));
$t2t->delete(qw(2.5));
- is($t2t->index('@0,0'), '2.3',
- q{DeleteChars procedure, updates affecting topIndex});
+ with_fixed_font {
+ is($t2t->index('@0,0'), '2.3',
+ q{DeleteChars procedure, updates affecting topIndex});
+ };
$t2t->delete('2.5');
is($t2t->index('@0,0'), '2.0');
}
@@ -32,6 +32,7 @@
# * metacity 2.16.3
# * metacity 2.10.3 (even more failures)
# * fvwm 2.5.18
+# * fvwm 2.6.5
# * blackbox 0.70.1
# * KWin: 3.0
# * Xfwm4: 4.2.3.2
@@ -68,6 +69,7 @@ my $kwin_problems = defined $wm_name && $wm_name eq 'KWin';
my $xfwm4_problems = defined $wm_name && $wm_name eq 'Xfwm4';
my $macosx_x11_problems = $Tk::platform eq 'unix' && $^O eq 'darwin';
my $fluxbox_problems = defined $wm_name && $wm_name eq 'Fluxbox';
+my $fvwm_problems = defined $wm_name && $wm_name eq 'FVWM';
my $poswin = 1;
my $netwm = 0;
@@ -129,6 +131,11 @@ sub raiseDelay () {
$mw->update;
}
+sub raiseDelayLonger () {
+ $mw->after(2000);
+ $mw->update;
+}
+
sub poswin ($;@) {
if ($poswin) {
for (@_) {
@@ -693,6 +700,7 @@ stdWindow;
$mw->idletasks;
$t->withdraw;
$t->deiconify;
+ if ($fvwm_problems && !$t->ismapped) { $t->deiconify }
ok($t->ismapped,
q{a window that has already been mapped should be mapped by deiconify()});
}
@@ -1774,6 +1782,13 @@ eval {
$mw->raise;
$mw->update;
raiseDelay;
+ if ($mw->stackorder("isabove", $t)) {
+ # Problem seen with twm on travis-ci system
+ # and on a Mac OS X system
+ # (http://www.cpantesters.org/cpan/report/404e4ab4-3738-11e3-850b-7bc3a04c628c)
+ diag "Window manager too slow? Delay and retry...";
+ raiseDelayLonger;
+ }
is($mw->stackorder("isabove", $t), 0,
q{A normal toplevel can't be raised above an overrideredirect toplevel});
$t->destroy;
@@ -2320,6 +2335,7 @@ SKIP: {
$mw->update;
$t->withdraw;
$t->state("normal");
+ if ($fvwm_problems && $t->state ne 'normal') { $t->deiconify }
is($t->state, "normal",
q{state change after map, normal});
}
@@ -2331,6 +2347,7 @@ SKIP: {
$mw->update;
$t->withdraw;
$t->deiconify;
+ if ($fvwm_problems && $fvwm_problems && $t->state ne 'normal') { $t->deiconify }
is($t->state, "normal",
q{state change after map, normal});
}
@@ -2408,6 +2425,7 @@ SKIP: {
is($t->state, "withdrawn");
is($t->ismapped, 0);
$t->deiconify;
+ if ($fvwm_problems && $t->state ne 'normal') { $t->deiconify }
is($t->state, "normal");
is($t->ismapped, 1);
}
@@ -3,14 +3,29 @@
use strict;
+use FindBin;
+use lib "$FindBin::RealBin";
+
use Tk;
use Test::More;
+
+use TkTest qw(wm_info);
+
# Win32 gets one <visibility> event on toplevel and one on content (as expected)
# UNIX/X is more complex, as windows overlap (deliberately)
our $tests = 6;
our $expect = 0;
plan 'no_plan'; # $tests for fast connections, $tests-1 for slow connections
+my $mw = new MainWindow;
+
+my %wm_info = wm_info($mw);
+my $wm_name = $wm_info{name};
+
+my $initial_ok_delay = 0.4;
+# GNOME Shell is sometimes slow
+my $ok_delay = $wm_name eq 'GNOME Shell' ? 1.0 : 0.5;
+
my $event = '<Map>';
my $why;
my $start;
@@ -24,7 +39,10 @@ sub begin
diag "Start $why $expect";
}
-my $mw = new MainWindow;
+# First setup timers to kill the script in case of timeouts
+$mw->after(5*1000, sub { diag "This test script takes longer than usual... it will maybe be killed in some seconds." });
+$mw->after(30*1000, sub { diag "Killing main window."; $mw->destroy });
+
my $l = $mw->Label(-text => 'Content')->pack;
#$l->bind($event,[\&mapped,"update"]);
$mw->bind($event,[\&mapped,"initial"]);
@@ -58,14 +76,14 @@ sub mapped
my $now = Tk::timeofday();
my $delay = $now - $start;
diag sprintf "%s $why %.3g $expect\n",$w->PathName,$delay;
- if ($state eq 'initial' && $delay > 0.4)
+ if ($state eq 'initial' && $delay > $initial_ok_delay)
{
$skip_slow_connection = 1;
return;
}
if ($expect-- > 0)
{
- cmp_ok($delay, "<", 0.5, $why);
+ cmp_ok($delay, "<", $ok_delay, $why);
}
}
@@ -4046,7 +4046,18 @@ ClientData clientData;
if (!SvMAGIC(sv))
{
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ if ((SvFLAGS(sv) & (SVp_IOK|SVp_NOK)) == (SVp_IOK|SVp_NOK))
+ {
+ /* RT #90077: if both SVp_IOK and SVp_NOK are set, then the
+ * SVf_IOK must not be set, otherwise arithmetic operations
+ * may use the wrong integer value
+ */
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ }
+ else
+ {
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ }
}
}
}
@@ -1,6 +0,0 @@
-#!/usr/bin/perl -w
-# -*- perl -*-
-
-print "1..0 # SKIP Cannot create MainWindow (maybe no X11 server is running or DISPLAY is not set?)\n";
-
-__END__
@@ -0,0 +1,6 @@
+#!/usr/bin/perl -w
+# -*- perl -*-
+
+print "1..0 # SKIP Cannot create Label widget (maybe no fonts are available at all?)\n";
+
+__END__
@@ -0,0 +1,6 @@
+#!/usr/bin/perl -w
+# -*- perl -*-
+
+print "1..0 # SKIP Cannot create MainWindow (maybe no X11 server is running or DISPLAY is not set?)\n";
+
+__END__