#!/usr/bin/perl -w
# -*- perl -*-
#
# Author: Slaven Rezic
#
use strict;
use FindBin;
use lib $FindBin::RealBin;
use Encode qw(encode);
use File::Copy qw(cp);
use File::Spec::Functions qw(catfile);
use File::Temp qw(tempdir);
use Tk;
use Tk::FBox;
BEGIN {
if (!eval q{
use Test::More;
use Devel::Peek;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
use TkTest qw(catch_grabs);
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
my $dir = tempdir(CLEANUP => 1);
die "Cannot create temporary directory" if !$dir;
my $encoding = "iso-8859-1";
if ($^O eq 'darwin') {
$encoding = 'utf-8';
}
# Preparations. May fail on some systems, see
# https://rt.cpan.org/Ticket/Display.html?id=75347
my($umlautdir, $umlautgif, $umlautxpm, $umlautxbm, $eurogif);
eval {
$umlautdir = catfile $dir, encode($encoding, "äöüß");
mkdir $umlautdir
or die "Cannot create $umlautdir: $!";
$umlautgif = catfile $umlautdir, encode($encoding, "äöüß.gif");
cp(Tk->findINC("Xcamel.gif"), $umlautgif)
or die "Can't copy Xcamel.gif to $umlautgif: $!";
$umlautxpm = catfile $umlautdir, encode($encoding, "èé.xpm");
cp(Tk->findINC("Camel.xpm"), $umlautxpm)
or die "Can't copy Camel.xpm to $umlautxpm: $!";
utf8::upgrade($umlautxpm); # upgrade to utf8 it before Perl/Tk...
$umlautxbm = catfile $umlautdir, encode($encoding, "ÈÉ.xbm");
cp(Tk->findINC("Tk.xbm"), $umlautxbm)
or die "Can't copy Tk.xbm to $umlautxbm: $!";
$eurogif = catfile $umlautdir, "\xe2\x82\xac.gif"; # the utf8-representation of \x{20ac} (Euro sign)
cp(Tk->findINC("Xcamel.gif"), $eurogif)
or die "Can't copy Xcamel.gif to $eurogif: $!";
};
if ($@) {
plan skip_all => $@;
exit 0;
}
plan tests => 13;
my $mw = tkinit;
$mw->geometry("+10+10");
######################################################################
# Various image formats
{
my $p = eval { $mw->Photo(-file => $umlautgif) };
is($@, "", "Create a photo with non-ascii chars in filename");
$p->delete if $p;
}
{
my $p = eval { $mw->Pixmap(-file => $umlautxpm) };
is($@, "", "Create a pixmap with non-ascii chars in filename");
$p->delete if $p;
}
{
my $p = eval { $mw->Bitmap(-file => $umlautxbm) };
is($@, "", "Create a bitmap with non-ascii chars in filename");
$p->delete if $p;
}
{
my $p = eval { $mw->Photo(-file => $eurogif) };
is($@, "", "Create a photo with chars > 0xff in filename");
$p->delete if $p;
}
######################################################################
# Bitmaps from file
{
my $l = eval { $mw->Label(-bitmap => '@' . $umlautxbm) };
is($@, "", "Create a widget with bitmap from filename with non-ascii chars");
if (Tk::Exists($l)) {
$l->pack;
$l->update;
$l->after(100);
$l->destroy;
}
}
######################################################################
# File box
catch_grabs {
my $fb = $mw->FBox;
$fb->configure(-initialdir => $umlautdir);
$fb->after(500, sub { $fb->destroy }) if $ENV{BATCH};
my $value = $fb->Show;
Dump($value) if defined $value;
pass("Setting FBox -initialdir with non-ascii directory name");
} 1;
catch_grabs {
my $fb = $mw->FBox;
$fb->configure(-initialfile => $umlautgif);
$fb->after(500, sub { $fb->destroy }) if $ENV{BATCH};
my $value = $fb->Show;
Dump($value) if defined $value;
pass("Setting FBox -initialfile with non-ascii file name");
} 1;
######################################################################
# Text
{
my @warnings;
my $t = $mw->Text->pack;
$t->insert("end", "\xfc" x 20);
$t->markSet('insert','end');
$t->focusForce;
$t->update;
{
@warnings = ();
local $SIG{__WARN__} = sub { push @warnings, @_ };
$t->eventGenerate('<Control-KeyPress>', -keysym=>'Left');
}
is("@warnings", "", "No utf-8 warnings");
is($t->index("insert"), "1.0", "Text: left word movement");
{
@warnings = ();
local $SIG{__WARN__} = sub { push @warnings, @_ };
$t->eventGenerate('<Control-KeyPress>', -keysym=>'Right');
}
is("@warnings", "", "No utf-8 warnings");
is($t->index("insert"), "1.20", "Text: right word movement"); # XXX 1.20 correct?
$t->destroy;
}
{
local $TODO = "Fix utf-8 warnings+errors in Text widget";
my @warnings;
my $t = $mw->Text->pack;
$t->insert("end", "\xfc" x 20);
$t->markSet('anchor',$t->index("current -1c"));
{
@warnings = ();
local $SIG{__WARN__} = sub { push @warnings, @_ };
is($t->index("1.19 wordstart"), "1.0");
}
is("@warnings", "", "No utf-8 warnings");
$t->destroy;
}
#MainLoop;
__END__