The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
use strict;
use Glib qw/TRUE FALSE/;
use Gtk2;
use Test::More;

if (UNIVERSAL::can("Gtk2::Pango::Cairo::FontMap", "new") &&
    Gtk2::Pango -> CHECK_VERSION(1, 10, 0)) {
  plan tests => 22;
} else {
  plan skip_all => "PangoCairo stuff: need Cairo and pango >= 1.10.0";
}

# $Id$

my $fontmap = Gtk2::Pango::Cairo::FontMap -> new();
isa_ok($fontmap, "Gtk2::Pango::Cairo::FontMap");
isa_ok($fontmap, "Gtk2::Pango::FontMap");

SKIP: {
  skip 'new 1.18 stuff', 3
    unless Gtk2::Pango -> CHECK_VERSION(1, 18, 0);

  $fontmap = Gtk2::Pango::Cairo::FontMap -> new_for_font_type('ft');
  
  skip 'new_for_font_type returned undef', 3
    unless defined $fontmap;

  isa_ok($fontmap, "Gtk2::Pango::Cairo::FontMap");
  isa_ok($fontmap, "Gtk2::Pango::FontMap");
  is($fontmap -> get_font_type(), 'ft');
}

$fontmap = Gtk2::Pango::Cairo::FontMap -> get_default();
isa_ok($fontmap, "Gtk2::Pango::Cairo::FontMap");
isa_ok($fontmap, "Gtk2::Pango::FontMap");

$fontmap -> set_resolution(72);
is($fontmap -> get_resolution(), 72);

my $context = $fontmap -> create_context();
isa_ok($context, "Gtk2::Pango::Context");

# Just to make sure this is a valid Gtk2::Pango::FontMap
isa_ok(($fontmap -> list_families())[0], "Gtk2::Pango::FontFamily");

my $target = Cairo::ImageSurface -> create("argb32", 100, 100);
my $cr = Cairo::Context -> create($target);

Gtk2::Pango::Cairo::update_context($cr, $context);

my $options = Cairo::FontOptions -> create();

# Function interface
{
  Gtk2::Pango::Cairo::Context::set_font_options($context, $options);
  isa_ok(Gtk2::Pango::Cairo::Context::get_font_options($context),
         "Cairo::FontOptions");

  Gtk2::Pango::Cairo::Context::set_resolution($context, 72);
  is(Gtk2::Pango::Cairo::Context::get_resolution($context), 72);
}

# Method interface
{
  isa_ok($context, "Gtk2::Pango::Cairo::Context");

  $context -> set_font_options($options);
  isa_ok($context -> get_font_options(), "Cairo::FontOptions");

  $context -> set_resolution(72);
  is($context -> get_resolution(), 72);
}

my $layout = Gtk2::Pango::Cairo::create_layout($cr);
isa_ok($layout, "Gtk2::Pango::Layout");

my $line = $layout -> get_line(0);

Gtk2::Pango::Cairo::show_layout_line($cr, $line);
Gtk2::Pango::Cairo::show_layout($cr, $layout);
Gtk2::Pango::Cairo::layout_line_path($cr, $line);
Gtk2::Pango::Cairo::layout_path($cr, $layout);

Gtk2::Pango::Cairo::update_layout($cr, $layout);

# FIXME: pango_cairo_show_glyph_string, pango_cairo_glyph_string_path.

SKIP: {
  skip "error line stuff", 0
    unless Gtk2::Pango -> CHECK_VERSION(1, 14, 0);

  Gtk2::Pango::Cairo::show_error_underline($cr, 23, 42, 5, 5);
  Gtk2::Pango::Cairo::error_underline_path($cr, 23, 42, 5, 5);
}

SKIP: {
  skip 'new 1.18 stuff', 6
    unless Gtk2::Pango -> CHECK_VERSION(1, 18, 0);

  $context -> set_shape_renderer(undef, undef);

  my $target = Cairo::ImageSurface -> create('argb32', 100, 100);
  my $cr = Cairo::Context -> create($target);

  my $layout = Gtk2::Pango::Cairo::create_layout($cr);
  Gtk2::Pango::Cairo::Context::set_shape_renderer(
    $layout -> get_context(),
    sub {
      my ($cr, $shape, $do_path, $data) = @_;

      isa_ok($cr, 'Cairo::Context');
      isa_ok($shape, 'Gtk2::Pango::AttrShape');
      ok(defined $do_path);
      is($data, 'bla');
    },
    'bla');
  $layout -> set_text('Bla');

  my $ink     = { x => 23, y => 42, width => 10, height => 15 };
  my $logical = { x => 42, y => 23, width => 15, height => 10 };
  my $attr = Gtk2::Pango::AttrShape -> new($ink, $logical, 0, 1);
  my $list = Gtk2::Pango::AttrList -> new();
  $list -> insert($attr);
  $layout -> set_attributes($list);

  Gtk2::Pango::Cairo::show_layout($cr, $layout);

  my $desc = Gtk2::Pango::FontDescription -> from_string('Sans 10');
  my $font = $fontmap -> load_font($context, $desc);
  skip 'could not find font', 2
    unless defined $font;
  isa_ok($font, 'Gtk2::Pango::Cairo::Font');
  isa_ok($font -> get_scaled_font(), 'Cairo::ScaledFont');
}

__END__

Copyright (C) 2005 by the gtk2-perl team (see the file AUTHORS for the
full list).  See LICENSE for more information.