The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
# -*- perl -*-

#
# $Id: 00-basic.t,v 1.11 2008/09/23 19:26:00 eserte Exp $
# Author: Slaven Rezic
#

use strict;

BEGIN {
    if (!eval q{
	use Test::More;
	1;
    }) {
	print "1..0 # skip: no Test::More module\n";
	exit;
    }
}

my $real_tests = 3;
plan tests => 1 + $real_tests;

use Tk;

my $sampletext;
BEGIN {
    eval q{
        use charnames ':full';
        $sampletext = "The quick brown fox jumps over the lazy dog.\nUnicode: Euro=\N{EURO SIGN}, C with acute=\N{LATIN SMALL LETTER C WITH ACUTE}, cyrillic sh=\x{0428}";
    };
    #warn $@;
}

if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }

use_ok("Tk::FontDialog");

my $top = eval { MainWindow->new };
SKIP: {
    skip "Cannot open main window. Error message <$@>", $real_tests
	if $@ || !$top;

    $top->geometry('+1+1');

    my($b, $f, $fd);

    my $apply_font = sub {
	my $font = shift;
	if (defined $font) {
	    $b->configure(-font => $font);
	    $f->RefontTree(-font => $font, -canvas => 1);
	}
    };

    $b = $top->Button(-text => 'Choose Font',
		      -command => sub {
			  my $font = $fd->Show;
			  $apply_font->($font);
		      })->pack;
    {
	$f = $top->Frame->pack;
	$f->Label(-text => 'Test RefontTree 1')->pack;
	my $f2 = $f->Frame->pack;
	$f2->Label(-text => 'Test RefontTree 2')->pack;
	my $c = $f2->Canvas(-width => 100, -height => 30)->pack;
	$c->createText(0,0,-anchor => 'nw', -text => 'Canvas Text');
    }

    $fd = $top->FontDialog(-nicefont => 0,
			   #-font => $b->cget(-font),
			   -title => 'Schriftart?',
			   #-familylabel => '~Schriftfamilie;',
			   #-sizelabel => '~Größe:',
			   #-weightlabel => '~Fett',
			   #-slantlabel  => '~Italic',
			   #-underlinelabel => '~Unterstrichen',
			   #-overstrikelabel => '~Durchgestrichen',
			   #-applylabel => 'Ü~bernehmen',
			   #-cancellabel => '~Abbruch',
			   #-altsamplelabel => 'A~lternative',
			   -applycmd => $apply_font,
			   -familylabel => 'Schrift~familie',
			   -fixedfontsbutton => 1,
			   -nicefontsbutton => 1,
			   ($Tk::VERSION >= 804 && $sampletext ? (-sampletext => $sampletext) : ()),
			  );

    my $fontname;
    eval {
	my $fd2 = $top->FontDialog;
	$fontname = $fd2->Show('-_testhack' => $ENV{BATCH});
    };
    is($@, "", "No exceptions");

 SKIP:
    {
	skip("No font selected", 1) if (!defined $fontname);
	my $descriptive = $top->GetDescriptiveFontName($fontname);
	my %fa  = $top->fontActual($fontname);
	my %fa2 = $top->fontActual($descriptive);
	is_deeply(\%fa, \%fa2, "Same font");
    }
    

    my $bf = $top->Frame->pack;
    my $okb = $bf->Button(-text => 'OK',
			  -command => sub {
			      pass();
			      $top->destroy;
			  }
			 )->pack(-side => 'left');
    $bf->Button(-text => 'Not OK',
		-command => sub {
		    fail();
		    $top->destroy;
		}
	       )->pack(-side => 'left');

    if ($ENV{BATCH}) {
	$top->after(1000, sub {
			$okb->invoke;
		    });
    }

    MainLoop;
}