BEGIN { $|=1; $^W=1; }
use strict;

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

use Tk;
use Tk::Font;
use Tk::Config;
use Getopt::Long;
use Data::Dumper;

plan tests => 34;

my $v;
GetOptions("v" => \$v)
    or die "usage: $0 [-v]";

my $Xft = $Tk::Config::xlib =~ /-lXft\b/;

my $mw = Tk::MainWindow->new;
$mw->geometry("+10+10");

##
## if there's only one (fixed) or no font family
## then something is wrong. Propably the envirionment
## and not perl/Tks fault.
##
{
    my @fam = ();
    eval { @fam = $mw->fontFamilies; };
    is($@, "", "fontFamilies");
    cmp_ok(@fam,">",1, "Num. of font families=".scalar @fam);
}
##
## Tk800.003 writes 'ont ...' in warning instead of 'font ...'
## fontActual expects one argument
##  opps,  looks like fault of ptksh
{
  eval { $mw->fontActual; };
  like($@, qr/^wrong # args: should be "font/,
       "fontActual without font error");
}
##
## Stephen O. Lidie reported that Tk800.003
## fontMeasure() and fontMeasure(fontname) gives
## SEGV on linux and AIX.
##
{
  my $fontname = ($^O eq 'MSWin32') ? 'ansifixed': 'fixed';
  eval { $mw->fontMeasure; };
  isnt($@, "", "fontMeasure documented to require two args, not zero");
  eval { $mw->fontMeasure($fontname); };
  isnt($@, "", "fontMeasure documented to require two args, not one");
  my $num = undef;
  eval { $num = $mw->fontMeasure($fontname, 'Hi'); };
  is($@, "", "fontMeasure works with fixed font and a string");
  ok(defined $num);
  cmp_ok($num, ">=", 2, "fontMeasure value is large enough");
  my $l = $mw->Label(-font => $fontname);
  my $name;
  eval { $name = $l->cget('-font') };
  is("$name", $fontname, "cget(-font) returns same fontname");
}

my @fam = $mw->fontFamilies;
if ($v)
 {
  diag "Font families:";
  foreach my $fam (@fam)
   {
    diag "* $fam";
   }
 }

my $times_tests = 4;
SKIP:
 {
  skip("Times not available", $times_tests)
      if !grep { /^times$/i } @fam;

  $mw->optionAdd('*Listbox.font','Times -12 bold');
  my $lb = $mw->Listbox()->pack;
  $lb->insert(end => '0',"\xff","\x{20ac}","\x{0289}");
  $lb->update;
  my $lf = $lb->cget('-font');
  diag "Font attributes: $$lf:" . join(',',$mw->fontActual($lf))
      if $v;

  my %fa = ($mw->fontActual($lf), $mw->fontMetrics($lf));

  skip("Times requested, but got $fa{-family}", $times_tests)
      if lc $fa{-family} !~ /^times$/i;

  my %expect = (-family => 'Times',
		-size   => -12, -weight => 'bold',
		-slant  => 'roman');
  foreach my $key (sort keys %expect)
   {
    my $val = $fa{$key};
    like($val, qr{\Q$expect{$key}}i, "Value of $key from fontActual (Times font)");
   }

  my @subfonts = $mw->fontSubfonts($lf);
  if ($v)
   {
    diag "Subfonts of $$lf:";
    foreach my $sf (@subfonts)
     {
      diag '* ' . join(',',@$sf);
     }
   }
 }

# This is really only needed for checking the -ascent and -descent values
# if Perl/Tk was built with XFT=1 and by requesting helvetica really
# the X11 helvetica was returned.
my $font_metric_tests = 10;
SKIP: {
 skip("Test only work on X11", $font_metric_tests)
     if $Tk::platform ne 'unix';

 my $l = $mw->Label(-font => '-adobe-helvetica-bold-r-normal--*-180-*-*-*-*-*-*');
 my $f = $l->cget(-font);
 my @subfonts = $mw->font('subfonts', $f);

 if ($Xft)
  {
   my $subfont_file = $subfonts[0]->[4];
   skip("Unexpected subfont file $subfont_file", $font_metric_tests)
       if $subfont_file !~ m{75dpi/helvB18(-ISO8859-1)?\.pcf(.gz)?$};
   if ($v)
    {
     diag("Subfont file is $subfont_file");
    }
  }

 my %fa = ($mw->fontActual($f), $mw->fontMetrics($f));

 skip("Helvetica requested, but got $fa{-family}", $font_metric_tests)
     if lc $fa{-family} ne 'helvetica';
 skip("18 pixels requested, but got " . -$fa{-size}, $font_metric_tests)
     if lc $fa{-size} != -18;

 my $font_dump_shown = 0;
 my %expected = (
		 "-weight"     => "bold",
		 "-underline"  => 0,
		 "-family"     => "helvetica",
		 "-slant"      => "roman",
		 "-size"       => -18,
		 "-overstrike" => 0,
		 "-ascent"     => 16,
		 "-descent"    => 5,
		 "-linespace"  => 21,
		 "-fixed"      => 0,
		);
 while(my($key,$val) = each %expected)
  {
   if (!is(lc $fa{$key}, $val, "Expected $key value (Helvetica font)"))
    {
     diag(Dumper(\@subfonts)) if !$font_dump_shown;
     $font_dump_shown++;
    }
  }
 $l->destroy;
}

{
 # This caused core dumps with Xft version of Perl/Tk
 my $l = $mw->Label(-font => '-*-*-bold-r-*--12-*-*-*-*-*-*-*');
 $l->destroy;
 pass("Core dump check (especially for XFT)");
}

{
 # This caused core dumps with Perl/Tk 804.027
 eval { $mw->fontMeasure(undef, -ascent)};
 like($@, qr{Cannot use undef as font object},
      "Core dump check with undef font object");

 eval { $mw->fontConfigure(undef) };
 like($@, qr{Cannot use undef as font object});

 eval { $mw->fontActual(undef) };
 like($@, qr{Cannot use undef as font object});
}

{
 # This caused core dumps with Perl/Tk 804.027
 my $l = $mw->Label(-font => "helvetica 10");
 my $f = $l->cget(-font);
 eval { $l->configure(-font => undef) };
 like($@, qr{\QCannot use undef value for object of type 'font'},
      "Core dump check with undef font in configure");
 # This used to be:
 #     is($l->cget(-font), $f, "Font stays unchanged");
 # but there's a bug in some Test::More versions, so I do have to do it
 # differently:
 my $got = "@{[ $l->cget(-font) ]}";
 my $expected = "$f";
 is($got, $expected, "Font stays unchanged");
 $l->destroy;

 eval { $mw->Label(-font => undef) };
 like($@, qr{\QCannot use undef value for object of type 'font'},
      "Core dump check with undef font in initial setup (label)");

 require Tk::TextList; # TextList seems to be special
 eval { $mw->TextList(-font => undef) };
 like($@, qr{\QCannot use undef value for object of type 'font'},
      "Core dump check with undef font in initial setup (textlist)");
 # FIXME XXX
 # The above failure causes a font to be left in the cache. The message:
 # Font -*-helvetica-medium-r-normal--14-*-*-*-*-iso8859-1 still in cache.
}

{
 my $l = $mw->Label;
 my $f = $l->cget(-font);
 isa_ok($f, 'Tk::Font');
 my $ascent = $f->measure(-ascent);
 ok(defined $ascent, "Got ascent from measure");
 eval { $f->actual(undef,undef) };
 like($@, qr{\Qwrong # args: should be "font actual font},
      "Does not get error about undef font object");
}

__END__