—

              
#!perl
use strict;
use warnings;
use v5.10; # for '//'
use open qw/:utf8 :std/;
use utf8;
use Config qw//;
use File::Find qw//;
use File::Spec qw//;
use XML::LibXML qw//;
{
  my $have_display;
  BEGIN {
    if (!@ARGV) {
      local $@;
      $have_display = eval {use Gtk3; Gtk3::init_check ()};
    }
  }
  my $parser = GirParser->new;
  if (!@ARGV && $have_display) {
    my @girs = find_girs ();
    my $gui = GirGUI->new ($parser, @girs);
    $gui->run;
    exit;
  }
  if (!@ARGV) {
    die 'Usage: perli11ndoc <library name>[::<element name>[::<element name>]]';
  }
  my $pattern = $ARGV[0];
  my ($lib_pattern, @element_patterns) = split /::/, $pattern;
  my $gir = find_gir ($lib_pattern);
  $parser->open ($gir);
  if (!@element_patterns) {
    print $parser->format_namespace;
  } else {
    print $parser->format_search_results (@element_patterns);
  }
}
# ------------------------------------------------------------------------------
sub find_gir {
  my ($lib_pattern) = @_;
  if ($lib_pattern !~ /^([^\d\-]+)-?(\d(?:\.\d)?)?$/) {
    die "Cannot recognize the library name\n";
  }
  my $name_wanted = $1;
  my $version_wanted = $2;
  if (defined $version_wanted && $version_wanted !~ /\./) {
    $version_wanted .= '.0';
  }
  my $match_func = sub {
    if (defined $version_wanted) {
      return $_ eq "$name_wanted-$version_wanted.gir";
    } else {
      return $_ =~ /^\Q$name_wanted\E-\d+\.\d+\.gir$/;
    }
  };
  my @girs = find_girs ($match_func);
  if (@girs == 0) {
    die "Could not find any matching GIR file\n";
  }
  if (@girs > 1) {
    my $girs_string = join (', ', map { $_->{path} } @girs);
    die "Found multiple matching GIR files: $girs_string; please be more specific\n";
  }
  return $girs[0]->{path};
}
sub find_girs {
  my ($match_func) = @_;
  $match_func //= sub { 1 };
  my @prefixes = ('/usr');
  my @env_vars = (
    {name => 'LD_LIBRARY_PATH', extra_depth => 1}, # /<prefix>/lib => /<prefix>
    {name => 'GI_TYPELIB_PATH', extra_depth => 2}, # /<prefix>/lib/girepository-1.0 => /<prefix>
  );
  foreach my $env_var (@env_vars) {
    next unless exists $ENV{$env_var->{name}};
    my @dirs = split /$Config::Config{path_sep}/, $ENV{$env_var->{name}};
    foreach my $dir (@dirs) {
      my @dir_parts = File::Spec->splitdir ($dir);
      my $prefix = File::Spec->catdir (
        @dir_parts[0 .. ($#dir_parts-$env_var->{extra_depth})]);
      if (-d $prefix) {
        push @prefixes, Cwd::abs_path ($prefix);
      }
    }
  }
  my %seen;
  my @search_dirs = grep { !$seen{$_}++ && -d $_ }
                    map { $_ . '/share/gir-1.0' }
                    @prefixes;
  my @girs;
  File::Find::find (sub {
                      if ($_ =~ m/\.gir$/ && $match_func->($_)) {
                        push @girs, {path => $File::Find::name,
                                     dir => $File::Find::dir,
                                     file => $_};
                      }
                    }, @search_dirs);
  return @girs;
}
# ------------------------------------------------------------------------------
# --- GirParser ----------------------------------------------------------------
# ------------------------------------------------------------------------------
package GirParser;
use strict;
use warnings;
sub new {
  my ($class) = @_;
  return bless {}, $class
}
sub open {
  my ($self, $gir) = @_;
  $self->{gir} = $gir;
  $self->{parser} = XML::LibXML->new;
  $self->{dom} = $self->{parser}->load_xml (location => $gir);
  $self->{xpc} = XML::LibXML::XPathContext->new;
  $self->{xpc}->registerNs ('core', 'http://www.gtk.org/introspection/core/1.0');
  $self->{repository} = $self->{dom}->documentElement;
  my $namespace_list = $self->{xpc}->find ('core:namespace', $self->{repository});
  if ($namespace_list->size != 1) {
    die 'Can only handle a single namespace';
  }
  $self->{namespace} = $namespace_list->pop;
  $self->{basename} = $self->construct_basename;
}
sub construct_basename {
  my ($self) = @_;
  my $name = $self->find_attribute ($self->{namespace}, 'name');
  my $version = $self->find_attribute ($self->{namespace}, 'version');
  $version =~ s/.0$//;
  $version = '' if $version eq '1';
  return $name . $version;
}
# ------------------------------------------------------------------------------
sub find_attribute {
  my ($self, $element, $attribute) = @_;
  my $attribute_list = $element->find ("\@$attribute");
  return if $attribute_list->size != 1;
  return $attribute_list->pop->value;
}
sub find_full_element_name {
  my ($self, $element) = @_;
  my $name = $self->find_attribute ($element, 'name');
  return () unless defined $name;
  if ($name =~ /\./) {
    die "Unexpected fully qualified name '$name' encountered; aborting\n";
  }
  my $package = '';
  my $current_element = $element;
  while (1) {
    my $parent = $current_element->parentNode;
    last unless defined $parent;
    if ($parent->nodeName eq 'namespace') {
      $package = $self->{basename} . '::' . $package;
      last;
    }
    $package = $self->find_attribute ($parent, 'name') . '::' . $package;
    $current_element = $parent;
  }
  my $full_name = $package . $name;
  $package =~ s/::$//;
  return ($package, $name, $full_name);
}
sub find_node_by_path {
  my ($self, $path) = @_;
  my $match_list = $self->{xpc}->find ($path, $self->{namespace});
  if ($match_list->size < 1) {
    die "Cannot find a matching element for the path $path\n";
  }
  if ($match_list->size > 1) {
    die "Found more than one matching element for the path $path\n";
  }
  return $match_list->pop;
}
sub find_parameters_and_return_value {
  my ($self, $element) = @_;
  my (@in, @out);
  my $parameter_list = $self->{xpc}->find ('core:parameters/core:parameter', $element);
  foreach my $parameter ($parameter_list->get_nodelist) {
    my $direction = $self->find_attribute ($parameter, 'direction') // 'in';
    if ($direction eq 'inout' || $direction eq 'out') {
      push @out, $parameter;
    }
    if ($direction eq 'inout' || $direction eq 'in') {
      push @in, $parameter;
    }
  }
  my $retval = undef;
  my $retval_list = $self->{xpc}->find ('core:return-value', $element);
  if ($retval_list->size == 1) {
    $retval = $retval_list->[0];
    if (defined $retval) {
      if ($self->find_type_name ($retval) eq 'none') {
        $retval = undef;
      }
    }
  }
  return (\@in, $retval, \@out);
}
sub find_type_name {
  my ($self, $element) = @_;
  # arrays
  my $array_list = $self->{xpc}->find ('core:array', $element);
  if ($array_list->size == 1) {
    my $array = $array_list->pop;
    my $prefix = 'reference to array of ';
    my $child_type_name = $self->find_type_name ($array);
    return $prefix . $child_type_name;
  }
  # callbacks
  my $callback_list = $self->{xpc}->find ('core:callback', $element);
  if ($callback_list->size == 1) {
    my $callback = $callback_list->pop;
    my ($in, $retval, $out) = $self->find_parameters_and_return_value ($callback);
    unshift @$out, $retval if defined $retval;
    my $in_list = join ', ', map { $self->find_type_name ($_) } @$in;
    my $out_list = join ', ', map { $self->find_type_name ($_) } @$out;
    my $in_text = $in_list ne '' ? "in: $in_list" : '';
    my $out_text = $out_list ne '' ? "; out: $out_list" : '';
    return "callback ($in_text$out_text)";
  }
  # bare types
  my $type_list = $self->{xpc}->find ('core:type', $element);
  return '[unknown type]' unless $type_list->size == 1;
  my $type = $type_list->pop;
  return $self->find_attribute ($type, 'name');
}
# ------------------------------------------------------------------------------
sub enumerate_namespace {
  my ($self, $descend) = @_;
  $descend //= 0;
  my @class_and_interface_sub_categories = (
    [Constructors => 'core:constructor'],
    [Methods => 'core:method'],
    [Functions => 'core:function'],
    [Signals => 'glib:signal'],
    [Properties => 'core:property'],
    [Fields => 'core:field'],
    ['Virtual methods' => 'core:virtual-method'],
  );
  my @record_sub_categories = (
    [Constructors => 'core:constructor'],
    [Methods => 'core:method'],
    [Functions => 'core:function'],
    [Fields => 'core:field'],
  );
  my @enum_and_bitfield_sub_categories = (
    [Functions => 'core:function'],
  );
  my @categories = (
    [Classes => 'core:class', \@class_and_interface_sub_categories, sub { shift =~ /Accessible$/ }],
    [Interfaces => 'core:interface', \@class_and_interface_sub_categories],
    [Records => 'core:record', \@record_sub_categories, sub { shift =~ /(?:Class|Iface|Interface|Private)$/ }],
    [Enumerations => 'core:enumeration', \@enum_and_bitfield_sub_categories],
    [Bitfields => 'core:bitfield', \@enum_and_bitfield_sub_categories],
    [Functions => 'core:function'],
    [Callbacks => 'core:callback'],
    [Constants => 'core:constant'],
    [Aliases => 'core:alias', undef, sub { shift =~ /_autoptr$/ }],
    ['Classes for accessibility' => 'core:class',
     \@class_and_interface_sub_categories,
     sub { shift !~ /Accessible$/ }],
    ['Records for object classes' => 'core:record',
     \@record_sub_categories,
     sub { shift !~ /Class$/ }],
    ['Records for interfaces' => 'core:record',
     \@record_sub_categories,
     sub { shift !~ /(?:Iface|Interface)$/ }],
  );
  my @results;
  foreach my $category (@categories) {
    my $heading = $category->[0];
    my $path = $category->[1];
    my $sub_categories = $category->[2] // undef;
    my $skip = $category->[3] // sub { 0 }; # accept all by default
    my $list = $self->{xpc}->find ($path, $self->{namespace});
    next if $list->size == 0;
    my @entries;
    foreach my $node ($list->get_nodelist) {
      my $node_path = $node->nodePath;
      my $name = $self->find_attribute ($node, 'name');
      next if $skip->($name);
      my @sub_results;
      if ($descend && defined $sub_categories) {
        foreach my $sub_category (@$sub_categories) {
          my $sub_heading = $sub_category->[0];
          my $sub_path = $sub_category->[1];
          my $sub_list = $self->{xpc}->find ($sub_path, $node);
          next if $sub_list->size == 0;
          my @sub_entries;
          foreach my $sub_node ($sub_list->get_nodelist) {
            my $sub_path = $sub_node->nodePath;
            my $sub_name = $self->find_attribute ($sub_node, 'name');
            push @sub_entries, {path => $sub_path,
                                name => $sub_name};
          }
          push @sub_results, [$sub_heading => \@sub_entries];
        }
      }
      push @entries, {path => $node_path,
                      name => $name,
                      sub_results => \@sub_results};
    }
    next unless @entries;
    push @results, [$heading => \@entries];
  }
  return \@results;
}
sub format_namespace {
  my ($self) = @_;
  my $text = '';
  my $name = $self->find_attribute ($self->{namespace}, 'name');
  my $version = $self->find_attribute ($self->{namespace}, 'version');
  $text .= "NAMESPACE\n\n  $name $version => " . $self->{basename} . "\n\n";
  my $results = $self->enumerate_namespace;
  foreach my $results (@$results) {
    my $heading = uc $results->[0];
    my $entries = $results->[1];
    next unless @$entries;
    $text .= "$heading\n\n";
    foreach my $entry (@$entries) {
      $text .= sprintf "  [%s](%s)\n", $entry->{name}, $entry->{path};
    }
    $text .= "\n";
  }
  $text =~ s/\n\n\Z/\n/;
  return $text;
}
# ------------------------------------------------------------------------------
sub format_search_results {
  my ($self, @search_terms) = @_;
  die 'Can only handle up to two search terms' if @search_terms > 2;
  my $query = @search_terms == 1 ?
    "*[\@name='$search_terms[0]']" :
    "*[\@name='$search_terms[0]']/*[\@name='$search_terms[1]']";
  my $match_list = $self->{xpc}->find ($query, $self->{namespace});
  if ($match_list->size == 0) {
    die "Cannot find a matching element for the search terms @search_terms\n";
  }
  my @matches = $match_list->get_nodelist;
  if (@matches > 1) {
    my $matches_string =
      join (', ', map { $self->format_full_element_name ($_) }
            @matches);
    die "Found two many matches: $matches_string; please be more specific\n";
  }
  my $match = $matches[0];
  return $self->format_node ($match);
}
sub format_node_by_path {
  my ($self, $path) = @_;
  my $node = $self->find_node_by_path ($path);
  return $self->format_node ($node);
}
sub format_node_name_by_path {
  my ($self, $path) = @_;
  my $node = $self->find_node_by_path ($path);
  return $self->format_full_element_name ($node);
}
sub format_node {
  my ($self, $node) = @_;
  my %categories = (
    alias => 'format_alias',
    bitfield => 'format_bitfield',
    callback => 'format_callback',
    class => 'format_class',
    constant => 'format_constant',
    constructor => 'format_constructor',
    enumeration => 'format_enumeration',
    field => 'format_field',
    function => 'format_function',
    method => 'format_method',
    property => 'format_property',
    interface => 'format_interface',
    record => 'format_record',
    'glib:signal' => 'format_signal',
    'virtual-method' => 'format_virtual_method',
  );
  my $type = $node->nodeName;
  my $handler = $categories{$type};
  if (!defined $handler) {
    die "Unknown node type '$type' encountered; aborting\n";
  }
  return $self->$handler ($node);
}
# ------------------------------------------------------------------------------
sub format_alias {
  my ($self, $element) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  my $type_name = $self->find_type_name ($element);
  my $full_type_name = $self->format_full_type_name ($type_name);
  $text .= "ALIAS\n\n  $full_name = $full_type_name\n";
  $text .= $self->format_description ($element);
  return $text;
}
# ------------------------------------------------------------------------------
sub format_bitfield {
  my ($self, $element) = @_;
  return $self->format_bitfield_and_enumeration ($element, 'BITFIELD');
}
sub format_enumeration {
  my ($self, $element) = @_;
  return $self->format_bitfield_and_enumeration ($element, 'ENUMERATION');
}
sub format_bitfield_and_enumeration {
  my ($self, $element, $heading) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  $text .= "$heading\n\n  $full_name\n";
  $text .= $self->format_description ($element);
  $text .= $self->format_sub_members ($element);
  $text .= $self->format_sub_functions ($element, 'FUNCTIONS');
  return $text;
}
# ------------------------------------------------------------------------------
sub format_callable {
  my ($self, $element, $heading, $synopsis_format, $flags_formatter) = @_;
  $flags_formatter //= 'format_callable_flags';
  my $text = '';
  my ($package, $name, $full_name) = $self->find_full_element_name ($element);
  my $flags = $self->$flags_formatter ($element);
  $text .= "$heading\n\n  $full_name$flags\n";
  my ($in, $retval, $out) = $self->find_parameters_and_return_value ($element);
  # --- synopsis ---
  my @in_names = map { '$' . $self->find_attribute ($_, 'name') } @$in;
  my @out_names = map { '$' . $self->find_attribute ($_, 'name') } @$out;
  if (defined $retval) {
    unshift @out_names, '$retval';
  }
  my $in_list = join ', ', @in_names;
  my $in_list_pre_comma = @in_names > 0 ? ", $in_list" : '';
  my $in_list_post_comma = @in_names > 0 ? "$in_list, " : '';
  my $out_list = join ', ', @out_names;
  my $out_list_parens = @out_names > 1 ? "($out_list)" : $out_list;
  my $out_list_assign = @out_names > 0 ? "$out_list_parens = " : '';
  my $synopsis = $synopsis_format;
  $synopsis =~ s/\[\[PACKAGE\]\]/$package/g;
  $synopsis =~ s/\[\[NAME\]\]/$name/g;
  $synopsis =~ s/\[\[NAME_UC\]\]/uc $name/ge;
  $synopsis =~ s/\[\[FULL_NAME\]\]/$full_name/g;
  $synopsis =~ s/\[\[IN_LIST\]\]/$in_list/g;
  $synopsis =~ s/\[\[IN_LIST_PRE_COMMA\]\]/$in_list_pre_comma/g;
  $synopsis =~ s/\[\[IN_LIST_POST_COMMA\]\]/$in_list_post_comma/g;
  $synopsis =~ s/\[\[OUT_LIST\]\]/$out_list/g;
  $synopsis =~ s/\[\[OUT_LIST_PARENS\]\]/$out_list_parens/g;
  $synopsis =~ s/\[\[OUT_LIST_ASSIGN\]\]/$out_list_assign/g;
  $text .= "\nSYNOPSIS\n\n  $synopsis\n";
  # --- description ---
  $text .= $self->format_description ($element);
  # --- in ---
  if (@$in) {
    $text .= "\nPARAMETERS\n\n";
    foreach my $parameter (@$in) {
      my $name = $self->find_attribute ($parameter, 'name');
      my $type_name = $self->find_type_name ($parameter);
      my $full_type_name = $self->format_full_type_name ($type_name);
      $text .= "  • $name: $full_type_name\n";
      my $doc = $self->format_docs ($parameter, '    ');
      if (defined $doc) {
        $text .= "$doc\n";
      }
      $text .= "\n";
    }
    $text =~ s/\n\n\Z/\n/;
  }
  # --- retval & out ---
  my $retval_type_name = 'none';
  if (defined $retval) {
    $retval_type_name = $self->find_type_name ($retval);
  }
  if ($retval_type_name ne 'none' || @$out) {
    $text .= "\nRETURN VALUES\n\n";
    if ($retval_type_name ne 'none') {
      my $full_retval_type_name =
        $self->format_full_type_name ($retval_type_name);
      $text .= "  • $full_retval_type_name\n";
      my $doc = $self->format_docs ($retval, '    ');
      if (defined $doc) {
        $text .= "$doc\n\n";
      }
    }
    if (@$out) {
      foreach my $parameter (@$out) {
        my $name = $self->find_attribute ($parameter, 'name');
        my $type_name = $self->find_type_name ($parameter);
        my $full_type_name = $self->format_full_type_name ($type_name);
        $text .= "  • $name: $full_type_name\n";
        my $doc = $self->format_docs ($parameter, '    ');
        if (defined $doc) {
          $text .= "$doc\n\n";
        }
      }
    }
    $text =~ s/\n\n\Z/\n/;
  }
  return $text;
}
sub format_callback {
  my ($self, $element) = @_;
  my $synopsis_format = <<'__EOS__';
sub {
    my ([[IN_LIST]]) = @_;
    ...
    return [[OUT_LIST_PARENS]];
  }
__EOS__
  return $self->format_callable ($element, 'CALLBACK', $synopsis_format);
}
sub format_constructor {
  my ($self, $element) = @_;
  my $synopsis_format = '$object = [[PACKAGE]]->[[NAME]] ([[IN_LIST]])';
  return $self->format_callable ($element, 'CONSTRUCTOR', $synopsis_format);
}
sub format_function {
  my ($self, $element) = @_;
  my $synopsis_format = '[[OUT_LIST_ASSIGN]][[FULL_NAME]] ([[IN_LIST]])';
  return $self->format_callable ($element, 'FUNCTION', $synopsis_format);
}
sub format_method {
  my ($self, $element) = @_;
  my $synopsis_format = '[[OUT_LIST_ASSIGN]]$object->[[NAME]] ([[IN_LIST]])';
  # Treat methods of class structs as functions.
  {
    my $parent = $element->parentNode;
    if ($parent->nodeName eq 'record' &&
        defined $self->find_attribute ($parent, 'glib:is-gtype-struct-for'))
    {
      $synopsis_format = '[[OUT_LIST_ASSIGN]][[FULL_NAME]] ($package[[IN_LIST_PRE_COMMA]])';
    }
  }
  return $self->format_callable ($element, 'METHOD', $synopsis_format);
}
sub format_signal {
  my ($self, $element) = @_;
  my $synopsis_format = <<'__EOS__';
$object->signal_connect ('[[NAME]]' => sub {
    my ($object, [[IN_LIST_POST_COMMA]]$data) = @_;
    ...
    return [[OUT_LIST_PARENS]];
  }, $data);
__EOS__
  return $self->format_callable ($element,
                                 'SIGNAL',
                                 $synopsis_format,
                                 'format_signal_flags');
}
sub format_virtual_method {
  my ($self, $element) = @_;
  my $synopsis_format = <<'__EOS__';
sub [[NAME_UC]] {
    my ($object[[IN_LIST_PRE_COMMA]]) = @_;
    ...
    return [[OUT_LIST_PARENS]];
  }
__EOS__
  return $self->format_callable ($element,
                                 'VIRTUAL METHOD',
                                 $synopsis_format,
                                 'format_virtual_method_flags');
}
# ------------------------------------------------------------------------------
sub format_class {
  my ($self, $element) = @_;
  my $format_hierarchy_and_interfaces = sub {
    my @parents;
    my $current_element = $element;
    while (1) {
      my $parent_name = $self->find_attribute ($current_element, 'parent');
      last unless defined $parent_name;
      unshift @parents, $self->format_full_type_name ($parent_name);
      # Stop if the parent is fully qualified, i.e., if it points elsewhere.
      last if $parent_name =~ /\./;
      my $parent_list =
        $self->{xpc}->find ("core:class[\@name='$parent_name']",
                            $self->{namespace});
      if ($parent_list->size != 1) {
        die "Found no or too many classes with name '$parent_name'\n";
      }
      $current_element = $parent_list->pop;
    }
    my @children;
    my $name = $self->find_attribute ($element, 'name');
    my $children_list =
      $self->{xpc}->find ("core:class[\@parent='$name']",
                          $self->{namespace});
    foreach my $child ($children_list->get_nodelist) {
      push @children, $self->format_full_element_name ($child);
    }
    my $hierarchy_text = '';
    if (@parents || @children) {
      push @parents, $self->format_full_element_name ($element);
      $hierarchy_text = "\nHIERARCHY\n\n";
      my $hook = '╰── '; # thanks, devhelp
      my $spacer = ' ' x length $hook;
      for (my $i = 0; $i < @parents; $i++) {
        $hierarchy_text .=
          '  ' .
          ($i > 0 ? (($spacer x ($i-1)) . $hook) : '') .
          $parents[$i] . "\n";
      }
      foreach my $child (@children) {
        $hierarchy_text .=
          '  ' .
          $spacer x $#parents . $hook .
          $child . "\n";
      }
    }
    my $impl_list = $self->{xpc}->find ('core:implements', $element);
    my $impl_text =
      $self->format_full_type_names ($impl_list, 'IMPLEMENTED INTERFACES');
    return $hierarchy_text . $impl_text;
  };
  return $self->format_class_and_interface ($element, 'CLASS',
                                            $format_hierarchy_and_interfaces);
}
sub format_interface {
  my ($self, $element) = @_;
  my $format_prerequisites_and_implementations = sub {
    my $prereq_list = $self->{xpc}->find ('core:prerequisite', $element);
    my $prereq_text =
      $self->format_full_type_names ($prereq_list, 'PREREQUISITES');
    my $name = $self->find_attribute ($element, 'name');
    my $impl_list =
      $self->{xpc}->find ("core:class[./core:implements[\@name='$name']]",
                          $self->{namespace});
    my $impl_text =
      $self->format_full_type_names ($impl_list, 'KNOWN IMPLEMENTATIONS');
    return $prereq_text . $impl_text;
  };
  return $self->format_class_and_interface ($element, 'INTERFACE',
                                            $format_prerequisites_and_implementations);
}
sub format_class_and_interface {
  my ($self, $element, $heading, $intro) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  $text .= "$heading\n\n  $full_name\n";
  $text .= $intro->();
  $text .= $self->format_description ($element);
  $text .= $self->format_sub_constructors ($element);
  $text .= $self->format_sub_methods ($element);
  $text .= $self->format_sub_functions ($element, 'CLASS FUNCTIONS');
  $text .= $self->format_sub_signals ($element);
  $text .= $self->format_sub_properties ($element);
  $text .= $self->format_sub_fields ($element);
  $text .= $self->format_sub_virtual_methods ($element);
  return $text;
}
# ------------------------------------------------------------------------------
sub format_constant {
  my ($self, $element) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  my $value = $self->find_attribute ($element, 'value');
  my $type_name = $self->find_type_name ($element);
  my $full_type_name = $self->format_full_type_name ($type_name);
  $text .= "CONSTANT\n\n  $full_name = $value ($full_type_name)\n";
  $text .= $self->format_description ($element);
  return $text;
}
# ------------------------------------------------------------------------------
sub format_field {
  my ($self, $element) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  my $type_name = $self->find_type_name ($element);
  my $full_type_name = $self->format_full_type_name ($type_name);
  my $flags = $self->format_field_flags ($element);
  $text .= "FIELD\n\n  $full_name: $full_type_name$flags\n";
  $text .= $self->format_description ($element);
  return $text;
}
# ------------------------------------------------------------------------------
sub format_property {
  my ($self, $element) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  my $type_name = $self->find_type_name ($element);
  my $full_type_name = $self->format_full_type_name ($type_name);
  my $flags = $self->format_property_flags ($element);
  $text .= "PROPERTY\n\n  $full_name: $full_type_name$flags\n";
  $text .= $self->format_description ($element);
  return $text;
}
# ------------------------------------------------------------------------------
sub format_record {
  my ($self, $element) = @_;
  my $text = '';
  my $full_name = $self->format_full_element_name ($element);
  $text .= "RECORD\n\n  $full_name\n";
  $text .= $self->format_description ($element);
  $text .= $self->format_sub_fields ($element);
  $text .= $self->format_sub_constructors ($element);
  $text .= $self->format_sub_methods ($element);
  $text .= $self->format_sub_functions ($element, 'FUNCTIONS');
  return $text;
}
# ------------------------------------------------------------------------------
sub format_sub_constructors {
  my ($self, $element) = @_;
  my $text = '';
  my $ctor_list = $self->{xpc}->find ('core:constructor', $element);
  if ($ctor_list->size > 0) {
    $text .= "\nCONSTRUCTORS\n\n";
    foreach my $ctor ($ctor_list->get_nodelist) {
      my $name = $self->find_attribute ($ctor, 'name');
      my $path = $ctor->nodePath;
      my $flags = $self->format_callable_flags ($ctor,
                                                qw/introspectable version/);
      $text .= "  • [$name]($path)$flags\n";
    }
  }
  return $text;
}
sub format_sub_fields {
  my ($self, $element) = @_;
  my $text = '';
  my $field_list = $self->{xpc}->find ('core:field', $element);
  if ($field_list->size > 0) {
    $text .= "\nFIELDS\n\n";
    foreach my $field ($field_list->get_nodelist) {
      my $name = $self->find_attribute ($field, 'name');
      my $path = $field->nodePath;
      my $type_name = $self->find_type_name ($field);
      my $full_type_name = $self->format_full_type_name ($type_name);
      my $flags = $self->format_field_flags ($field, qw/introspectable/);
      $text .= "  • [$name]($path): $full_type_name$flags\n";
    }
  }
  return $text;
}
sub format_sub_functions {
  my ($self, $element, $heading) = @_;
  my $text = '';
  my $function_list = $self->{xpc}->find ('core:function', $element);
  if ($function_list->size > 0) {
    $text .= "\n$heading\n\n";
    foreach my $function ($function_list->get_nodelist) {
      my $name = $self->find_attribute ($function, 'name');
      my $path = $function->nodePath;
      my $flags = $self->format_callable_flags ($function,
                                                qw/introspectable version/);
      $text .= "  • [$name]($path)$flags\n";
    }
  }
  return $text;
}
sub format_sub_members {
  my ($self, $element) = @_;
  my $text = '';
  my $member_list = $self->{xpc}->find ('core:member', $element);
  if ($member_list->size > 0) {
    $text .= "\nMEMBERS\n";
    foreach my $member ($member_list->get_nodelist) {
      my $name = $self->find_attribute ($member, 'name');
      my $value = $self->find_attribute ($member, 'value');
      $text .= "\n  • $name = $value\n";
      my $doc = $self->format_docs ($member, '    ');
      if (defined $doc) {
        $text .= "$doc\n";
      }
    }
  }
  return $text;
}
sub format_sub_methods {
  my ($self, $element) = @_;
  my $text = '';
  my $method_list = $self->{xpc}->find ('core:method', $element);
  if ($method_list->size > 0) {
    $text .= "\nMETHODS\n\n";
    foreach my $method ($method_list->get_nodelist) {
      my $name = $self->find_attribute ($method, 'name');
      my $path = $method->nodePath;
      my $flags = $self->format_callable_flags ($method,
                                                qw/introspectable version/);
      $text .= "  • [$name]($path)$flags\n";
    }
  }
  return $text;
}
sub format_sub_properties {
  my ($self, $element) = @_;
  my $text = '';
  my $property_list = $self->{xpc}->find ('core:property', $element);
  if ($property_list->size > 0) {
    $text .= "\nPROPERTIES\n\n";
    foreach my $property ($property_list->get_nodelist) {
      my $name = $self->find_attribute ($property, 'name');
      my $path = $property->nodePath;
      my $type_name = $self->find_type_name ($property);
      my $full_type_name = $self->format_full_type_name ($type_name);
      my $flags = $self->format_property_flags ($property, qw/version/);
      $text .= "  • [$name]($path): $full_type_name$flags\n";
    }
  }
  return $text;
}
sub format_sub_signals {
  my ($self, $element) = @_;
  my $text = '';
  my $signal_list = $self->{xpc}->find ('glib:signal', $element);
  if ($signal_list->size > 0) {
    $text .= "\nSIGNALS\n\n";
    foreach my $signal ($signal_list->get_nodelist) {
      my $name = $self->find_attribute ($signal, 'name');
      my $path = $signal->nodePath;
      my $flags = $self->format_signal_flags ($signal, qw/version/);
      $text .= "  • [$name]($path)$flags\n";
    }
  }
  return $text;
}
sub format_sub_virtual_methods {
  my ($self, $element) = @_;
  my $text = '';
  my $vfunc_list = $self->{xpc}->find ('core:virtual-method', $element);
  if ($vfunc_list->size > 0) {
    $text .= "\nVIRTUAL METHODS\n\n";
    foreach my $vfunc ($vfunc_list->get_nodelist) {
      my $name = $self->find_attribute ($vfunc, 'name');
      my $path = $vfunc->nodePath;
      my $flags = $self->format_virtual_method_flags ($vfunc);
      $text .= "  • [$name]($path)$flags\n";
    }
  }
  return $text;
}
# ------------------------------------------------------------------------------
sub format_deprecation_docs {
  my ($self, $element) = @_;
  my $deprecated = $self->find_attribute ($element, 'deprecated') // 0;
  return unless $deprecated;
  my $text = '';
  my $version = $self->find_attribute ($element, 'deprecated-version');
  if (defined $version) {
    $text .= "Deprecated since: $version.";
  }
  my $doc_dep_list = $self->{xpc}->find ('core:doc-deprecated', $element);
  if ($doc_dep_list->size == 1) {
    $text .= '  ' . $doc_dep_list->pop->textContent;
  }
  return if $text eq '';
  return $text;
}
sub format_description {
  my ($self, $element) = @_;
  my $docs = $self->format_docs ($element);
  return defined $docs ? "\nDESCRIPTION\n\n$docs\n" : '';
}
sub format_docs {
  my ($self, $element, $indent) = @_;
  $indent //= '  ';
  my $text = '';
  # The normal docs.
  my $docs_list = $self->{xpc}->find ('core:doc', $element);
  if ($docs_list->size == 1) {
    $text .= $docs_list->pop->textContent;
  }
  # The version constraint.
  my $ver = $self->format_version_constraint ($element);
  $text .= "\n\n$ver\n" if defined $ver;
  # The deprecation docs.
  my $dep = $self->format_deprecation_docs ($element);
  $text .= "\n\n$dep\n" if defined $dep;
  return if $text eq '';
  # Extract code blocks so that they are not wrapped.
  my $code_block_pattern = qr/\|\[\n?(.*?)\n?\]\|/s;
  my $empty_code_block = '|[]|';
  my $empty_code_block_pattern = qr/\|\[\]\|/;
  my @code_blocks = $text =~ m/$code_block_pattern/g;
  $text =~ s/$code_block_pattern/$empty_code_block/g;
  # Remove leading white space as fill() otherwise takes it for starting a new
  # paragraph.  Do this after the code block extraction to preserve their
  # indentation.
  $text =~ s/^[ \t]+//mg;
  require Text::Wrap;
  my $formatted_text = Text::Wrap::fill ($indent, $indent, $text);
  while ($formatted_text =~ m/$empty_code_block_pattern/g) {
    my $code_block = shift @code_blocks;
    $code_block =~ s/^/$indent/mg;
    my $divider = '-' x (76-length($indent));
    my $formatted_code_block =
      "\n$indent$divider\n$code_block\n$indent$divider";
    $formatted_text =~
      s/(?:\n)?(?:$indent)?$empty_code_block_pattern/$formatted_code_block/;
  }
  return $formatted_text;
}
sub format_full_element_name {
  my ($self, $element) = @_;
  my (undef, undef, $full_name) = $self->find_full_element_name ($element);
  return $full_name;
}
sub format_full_type_name {
  my ($self, $name) = @_;
  if ($name =~ /\./) { # fully qualified
    $name =~ s/\./::/g;
    return $name;
  }
  if ($name =~ /^[A-Z]/) { # local
    return $self->{basename} . '::' . $name;
  }
  return $name; # global
}
sub format_full_type_names {
  my ($self, $list, $heading) = @_;
  my $text = '';
  if ($list->size > 0) {
    $text .= "\n$heading\n\n";
    foreach my $node ($list->get_nodelist) {
      my $type_name = $self->find_attribute ($node, 'name');
      my $full_type_name = $self->format_full_type_name ($type_name);
      $text .= "  • $full_type_name\n";
    }
  }
  return $text;
}
sub format_version_constraint {
  my ($self, $element) = @_;
  my $version = $self->find_attribute ($element, 'version');
  return if !defined $version;
  return "Since: $version.";
}
# ------------------------------------------------------------------------------
sub format_flags {
  my ($self, $element, $available, $wanted) = @_;
  $wanted //= [];
  my @texts;
  foreach my $flag (@$available) {
    my $name = $flag->[0];
    my $default = $flag->[1];
    my $formatter = $flag->[2];
    if (@$wanted) {
      next unless grep { $_ eq $name } @$wanted;
    }
    my $value = $self->find_attribute ($element, $name) // $default;
    my $text = $formatter->($value);
    push @texts, $text if defined $text;
  }
  return '' unless @texts;
  return ' [' . join (', ', @texts) . ']';
}
sub format_callable_flags {
  my ($self, $element, @wanted) = @_;
  # name, default, formatter
  my @available = (
    ['introspectable', 1,     sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }],
    ['deprecated',     0,     sub { $_[0] ? "deprecated" : undef }],
    ['moved-to',       undef, sub { defined $_[0] ? "moved to $_[0]" : undef }],
    ['shadowed-by',    undef, sub { defined $_[0] ? "shadowed by $_[0]" : undef }], # FIXME: Format $_[0] properly.
    ['throws',         0,     sub { $_[0] ? "throws" : undef }],
    ['version',        undef, sub { defined $_[0] ? "available since $_[0]" : undef }],
    ['shadows',        undef, sub { defined $_[0] ? "shadows $_[0]" : undef }],     # FIXME: Format $_[0] properly.
  );
  return $self->format_flags ($element, \@available, \@wanted);
}
sub format_field_flags {
  my ($self, $element, @wanted) = @_;
  # name, default, formatter
  my @available = (
    ['introspectable', 1, sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }],
    ['readable',       1, sub { $_[0] ? 'readable' : undef }],
    ['writable',       1, sub { $_[0] ? 'writable' : undef }],
  );
  return $self->format_flags ($element, \@available, \@wanted);
}
sub format_property_flags {
  my ($self, $element, @wanted) = @_;
  my @available = (
    ['deprecated', 0,     sub { $_[0] ? "deprecated" : undef }],
    ['version',    undef, sub { defined $_[0] ? "available since $_[0]" : undef }],
    ['readable',   1,     sub { $_[0] ? 'readable' : undef }],
    ['writable',   0,     sub { $_[0] ? 'writable' : undef }],
  );
  return $self->format_flags ($element, \@available, \@wanted);
}
sub format_signal_flags {
  my ($self, $element, @wanted) = @_;
  # name, default, formatter
  my @available = (
    ['deprecated', 0,     sub { $_[0] ? "deprecated" : undef }],
    ['version',    undef, sub { defined $_[0] ? "available since $_[0]" : undef }],
    ['when',       undef, sub { defined $_[0] ? "$_[0]" : undef }],
    ['no-recurse', 0,     sub { $_[0] ? "no recurse" : undef }],
    ['detailed',   0,     sub { $_[0] ? "detailed" : undef }],
  );
  return $self->format_flags ($element, \@available, \@wanted);
}
sub format_virtual_method_flags {
  my ($self, $element, @wanted) = @_;
  my $name = $self->find_attribute ($element, 'name');
  my @available = (
    ['introspectable', 1,     sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }],
    ['invoker',        undef, sub { defined $_[0] && $_[0] ne $name ? "invoked by $_[0]" : undef }],
    ['version',        undef, sub { defined $_[0] ? "available since $_[0]" : undef }],
  );
  return $self->format_flags ($element, \@available, \@wanted);
}
# ------------------------------------------------------------------------------
# --- GirGUI ----------------------------------------------------------------
# ------------------------------------------------------------------------------
package GirGUI;
use strict;
use warnings;
use File::Basename qw//;
sub TRUE () {1}
sub FALSE () {0}
sub FILE_MENU_COL_TEXT () { 0 }
sub FILE_MENU_COL_FILE () { 1 }
sub FILE_MENU_COL_DIR () { 2 }
sub FILE_MENU_COL_PATH () { 3 }
sub FILE_MENU_COL_IS_SENSITIVE () { 4 }
sub GIR_VIEW_COL_TEXT () { 0 }
sub GIR_VIEW_COL_PATH () { 1 }
sub GIR_VIEW_COL_IS_CATEGORY () { 2 }
sub GIR_VIEW_COL_IS_VISIBLE () { 3 }
sub new {
  my ($class, $parser, @girs) = @_;
  if (!Gtk3::CHECK_VERSION (3, 10, 0)) {
    die "Need gtk+ >= 3.10 for the GUI\n";
  }
  my $self = bless {
    parser => $parser,
  }, $class;
  my $window = Gtk3::Window->new;
  $self->setup_file_menu (@girs);
  $self->setup_gir_view;
  $self->setup_search_entry;
  $self->setup_path_bar;
  $self->setup_result_view;
  my $gir_view_window = Gtk3::ScrolledWindow->new;
  $gir_view_window->add ($self->{gir_view});
  my $result_view_window = Gtk3::ScrolledWindow->new;
  $result_view_window->add ($self->{result_view});
  my $side_box = Gtk3::Box->new ('vertical', 2);
  $side_box->pack_start ($self->{file_menu}, FALSE, FALSE, 0);
  $side_box->pack_start ($gir_view_window, TRUE, TRUE, 0);
  $side_box->pack_start ($self->{search_entry}, FALSE, FALSE, 0);
  $side_box->set (margin => 2);
  my $result_box = Gtk3::Box->new ('vertical', 0);
  $result_box->pack_start ($self->{path_bar}, FALSE, FALSE, 0);
  $result_box->pack_start ($result_view_window, TRUE, TRUE, 0);
  my $paned = Gtk3::Paned->new ('horizontal');
  $paned->pack1 ($side_box, TRUE, TRUE);
  $paned->pack2 ($result_box, TRUE, TRUE);
  $paned->set_position (300);
  $window->add ($paned);
  $window->signal_connect (delete_event => sub { $self->quit; });
  $window->set_default_geometry (900, 800);
  my $accel_group = Gtk3::AccelGroup->new;
  $accel_group->connect (Gtk3::Gdk::KEY_q (), qw/control-mask/, [], sub {
    $self->quit;
    return Gtk3::EVENT_STOP ();
  });
  $accel_group->connect (Gtk3::Gdk::KEY_k (), qw/control-mask/, [], sub {
    $self->{search_entry}->grab_focus;
    return Gtk3::EVENT_STOP ();
  });
  $window->add_accel_group ($accel_group);
  $self->{window} = $window;
  return $self;
}
sub filter_gir_view {
  my ($self, $criterion) = @_;
  my $view = $self->{gir_view};
  my $model = $self->{gir_model};
  my $filter_model = $self->{gir_filter_model};
  if (!defined $criterion || $criterion eq '') {
    # Make everything visible.
    $model->foreach (sub {
      my (undef, undef, $iter) = @_;
      $model->set ($iter, GIR_VIEW_COL_IS_VISIBLE, TRUE);
      return FALSE; # continue
    });
    # Scroll to selected element.
    my $selection = $view->get_selection;
    my ($selected_model, $selected_iter) = $selection->get_selected;
    if (defined $selected_iter) {
      my $selected_path = $selected_model->get_path ($selected_iter);
      $view->scroll_to_cell ($selected_path, undef, FALSE, 0.5, 0.5);
    }
  } else {
    my $re;
    if ($criterion =~ m|\A/.+/\z|) {
      $criterion =~ s|\A/(.+)/\z|$1|;
      $re = qr/$criterion/;
    } else {
      $re = qr/\Q$criterion\E/i;
    }
    my $check_tree;
    $check_tree = sub {
      my ($iter) = @_;
      my @children = map { $model->iter_nth_child ($iter, $_) }
                         0..$model->iter_n_children ($iter);
      foreach my $child (@children) {
        my ($text, $is_cat) = $model->get ($child,
                                           GIR_VIEW_COL_TEXT,
                                           GIR_VIEW_COL_IS_CATEGORY);
        if ($is_cat || $text !~ $re) { # no match
          $model->set ($child, GIR_VIEW_COL_IS_VISIBLE, FALSE);
          $check_tree->($child); # descend
        } else { # match
          # Make the element and all its parents visible.
          my $cur = $child;
          do {
            $model->set ($cur, GIR_VIEW_COL_IS_VISIBLE, TRUE);
          } while (defined ($cur = $model->iter_parent ($cur)));
          # Expand the matching element and all its parents.
          $view->expand_to_path (
            $filter_model->convert_child_path_to_path (
              $model->get_path ($child)));
          # No need to descend as we want all children of matching elements to
          # be visible.  (All elements are visible by default.)
        }
      }
    };
    $check_tree->(undef); # start with the virtual root node
  }
}
sub display_results {
  my ($self, $results) = @_;
  my $b = $self->{result_buffer};
  $b->delete ($b->get_start_iter (), $b->get_end_iter ());
  my $iter = $b->get_start_iter ();
  my $insert_part = sub {
    my ($start, $end) = @_;
    $b->insert ($iter, substr ($results, $start, $end - $start));
  };
  my ($prev_match_start, $prev_match_end) = (0, 0);
  while ($results =~ m/\[([^\n\]]+)\]\(([^\n\)]+)\)/g) {
    my ($link_text, $link_target) = ($1, $2);
    my ($match_start, $match_end) = ($-[0], $+[0]);
    if ($match_start != $prev_match_end) {
      $insert_part->($prev_match_end, $match_start);
    }
    my $tag = $b->create_tag (undef, foreground => 'blue');
    $tag->{__target} = $link_target;
    $b->insert_with_tags ($iter, $link_text, $tag);
    ($prev_match_start, $prev_match_end) = ($match_start, $match_end);
  }
  my $end_offset = length ($results);
  if ($prev_match_end != $end_offset) {
    $insert_part->($prev_match_end, $end_offset);
  }
}
sub run {
  my ($self) = @_;
  $self->{window}->show_all;
  Gtk3::main ();
}
sub setup_file_menu {
  my ($self, @girs) = @_;
  my $file_model = Gtk3::TreeStore->new (qw/Glib::String
                                            Glib::String
                                            Glib::String
                                            Glib::String
                                            Glib::Boolean/);
  my $file_menu = Gtk3::ComboBox->new_with_model ($file_model);
  my $renderer = Gtk3::CellRendererText->new;
  $file_menu->pack_start ($renderer, TRUE);
  $file_menu->set_attributes ($renderer,
                              text => FILE_MENU_COL_TEXT,
                              sensitive => FILE_MENU_COL_IS_SENSITIVE);
  $file_menu->set_id_column (FILE_MENU_COL_PATH);
  my $prompt = '<Select GIR>';
  $file_model->set ($file_model->append,
                    FILE_MENU_COL_TEXT, $prompt,
                    FILE_MENU_COL_IS_SENSITIVE, FALSE);
  $file_menu->set_active (0);
  my %dirs;
  $dirs{$_->{dir}}++ for @girs;
  my $n_dirs = scalar keys %dirs;
  foreach my $gir (sort { $a->{file} cmp $b->{file} } @girs) {
    my $text = File::Basename::fileparse ($gir->{file}, qr/\.gir$/);
    if ($n_dirs > 1) {
      my $dir = $gir->{dir};
      $dir =~ s|/share/gir-1\.0$||;
      $text .= ' (' . $dir . ')';
    }
    $file_model->set ($file_model->append,
                      FILE_MENU_COL_TEXT, $text,
                      FILE_MENU_COL_FILE, $gir->{file},
                      FILE_MENU_COL_DIR, $gir->{dir},
                      FILE_MENU_COL_PATH, $gir->{path},
                      FILE_MENU_COL_IS_SENSITIVE, TRUE);
  }
  $file_menu->signal_connect (changed => sub {
    my (undef, $iter) = $file_menu->get_active_iter;
    $self->{parser}->open ($file_model->get ($iter, FILE_MENU_COL_PATH));
    $self->update_gir_view;
  });
  $self->{file_menu} = $file_menu;
}
sub setup_gir_view {
  my ($self) = @_;
  my $gir_model = Gtk3::TreeStore->new (qw/Glib::String
                                           Glib::String
                                           Glib::Boolean
                                           Glib::Boolean/);
  my $gir_filter_model = Gtk3::TreeModelFilter->new ($gir_model);
  $gir_filter_model->set_visible_column (GIR_VIEW_COL_IS_VISIBLE);
  my $gir_view = Gtk3::TreeView->new_with_model ($gir_filter_model);
  $gir_view->insert_column_with_attributes (
    GIR_VIEW_COL_TEXT, 'Element',
    Gtk3::CellRendererText->new,
    text => GIR_VIEW_COL_TEXT);
  $gir_view->set_headers_visible (FALSE);
  $gir_view->signal_connect (key_press_event => sub {
    my (undef, $event) = @_;
    if ($event->keyval == Gtk3::Gdk::KEY_Left () ||
        $event->keyval == Gtk3::Gdk::KEY_Right ()) {
      my $selection = $gir_view->get_selection;
      my ($model, $iter) = $selection->get_selected;
      if (defined $iter) {
        my $path = $model->get_path ($iter);
        if ($event->keyval == Gtk3::Gdk::KEY_Left ()) {
          $gir_view->collapse_row ($path);
        } else {
          $gir_view->expand_row ($path, FALSE);
        }
      }
      return Gtk3::EVENT_STOP ();
    }
    return Gtk3::EVENT_PROPAGATE ();
  });
  $gir_view->get_selection->signal_connect (changed => sub {
    $self->go_to_selection
      unless $self->{suppress_gir_view_selection_changes};
  });
  $self->{gir_model} = $gir_model;
  $self->{gir_filter_model} = $gir_filter_model;
  $self->{gir_view} = $gir_view;
}
sub setup_path_bar {
  my ($self) = @_;
  my $path_bar = PathBar->new (orientation => 'horizontal', spacing => 2);
  $path_bar->set_update_func (sub {
    my ($name, $path) = @_;
    $self->update_results ($path);
  });
  $self->{path_bar} = $path_bar;
}
sub setup_search_entry {
  my ($self) = @_;
  my $wait_time_ms = 500;
  my $search_entry = Gtk3::SearchEntry->new;
  $search_entry->signal_connect (search_changed => sub {
    # Use a timeout which is reset when the search text changes so that we do
    # not filter the view too often.
    if (defined $search_entry->{__timer_id}) {
      Glib::Source->remove ($search_entry->{__timer_id});
    }
    $search_entry->{__timer_id} = Glib::Timeout->add ($wait_time_ms, sub {
      $self->filter_gir_view ($search_entry->get_text);
      $search_entry->{__timer_id} = undef;
      return Glib::SOURCE_REMOVE ();
    });
  });
  $self->{search_entry} = $search_entry;
}
sub setup_result_view {
  my ($self) = @_;
  my $result_buffer = Gtk3::TextBuffer->new (undef);
  my $result_view = Gtk3::TextView->new_with_buffer ($result_buffer);
  $result_view->set (editable => FALSE, margin => 2);
  my $display = $result_view->get_display ();
  $result_view->{__hand_cursor} = Gtk3::Gdk::Cursor->new_from_name ($display, 'pointer');
  $result_view->{__regular_cursor} = Gtk3::Gdk::Cursor->new_from_name ($display, 'text');
  my $hovering_over_link = sub {
    my ($event) = @_;
    my ($x, $y) = $result_view->window_to_buffer_coords ('widget', $event->x, $event->y);
    my $iter = $result_view->get_iter_at_location ($x, $y);
    if (!$iter) {
      return;
    }
    my $tags = $iter->get_tags ();
    foreach my $tag (@$tags) {
      if (defined $tag->{__target}) {
        return $tag;
      }
    }
    return;
  };
  $result_view->{__hovering} = FALSE;
  $result_view->signal_connect (motion_notify_event => sub {
    my ($result_view, $event) = @_;
    my $hovering = defined $hovering_over_link->($event);
    if ($result_view->{__hovering} != $hovering) {
      $result_view->{__hovering} = $hovering;
      $result_view->get_window ('text')->set_cursor (
        $hovering ? $result_view->{__hand_cursor} : $result_view->{__regular_cursor});
    }
    return Gtk3::EVENT_PROPAGATE ();
  });
  my $handle_button = sub {
    my ($event, $cb) = @_;
    if ($event->button == Gtk3::Gdk::BUTTON_PRIMARY ()) {
      my $tag = $hovering_over_link->($event);
      if (defined $tag) {
        if (defined $cb) {
          $cb->($tag);
        }
        return Gtk3::EVENT_STOP ();
      }
    }
    return Gtk3::EVENT_PROPAGATE ();
  };
  $result_view->signal_connect (button_press_event => sub {
    my ($result_view, $event) = @_;
    return $handle_button->($event);
  });
  $result_view->signal_connect (button_release_event => sub {
    my ($result_view, $event) = @_;
    return $handle_button->($event, sub {
      $self->go_to_path ($_[0]->{__target});
    });
  });
  $self->{result_buffer} = $result_buffer;
  $self->{result_view} = $result_view;
}
sub update_gir_view {
  my ($self) = @_;
  $self->{suppress_gir_view_selection_changes} = TRUE;
  $self->{gir_model}->clear;
  $self->{search_entry}->set_text ('');
  $self->{path_bar}->clear;
  my $inserter = sub {
    my ($iter, $text, $path, $is_cat, $is_vis) = @_;
    $self->{gir_model}->set ($iter,
                             GIR_VIEW_COL_TEXT, $text,
                             GIR_VIEW_COL_PATH, $path,
                             GIR_VIEW_COL_IS_CATEGORY, $is_cat,
                             GIR_VIEW_COL_IS_VISIBLE, $is_vis);
  };
  my $results = $self->{parser}->enumerate_namespace (TRUE);
  foreach my $result (@$results) {
    my $heading = $result->[0];
    my $entries = $result->[1];
    my $heading_iter = $self->{gir_model}->append;
    $inserter->($heading_iter, $heading, undef, TRUE, TRUE);
    next unless defined $entries;
    foreach my $entry (@$entries) {
      my $iter = $self->{gir_model}->append ($heading_iter);
      $inserter->($iter, $entry->{name}, $entry->{path}, FALSE, TRUE);
      next unless defined $entry->{sub_results};
      foreach my $sub_result (@{$entry->{sub_results}}) {
        my $sub_heading = $sub_result->[0];
        my $sub_entries = $sub_result->[1];
        my $sub_heading_iter = $self->{gir_model}->append ($iter);
        $inserter->($sub_heading_iter, $sub_heading, undef, TRUE, TRUE);
        next unless defined $sub_entries;
        foreach my $sub_entry (@$sub_entries) {
          my $sub_iter = $self->{gir_model}->append ($sub_heading_iter);
          $inserter->($sub_iter, $sub_entry->{name}, $sub_entry->{path}, FALSE, TRUE);
        }
      }
    }
  }
  $self->{suppress_gir_view_selection_changes} = FALSE;
  $self->display_results ($self->{parser}->format_namespace);
}
sub go_to_selection {
  my ($self) = @_;
  my $selection = $self->{gir_view}->get_selection;
  my ($model, $iter) = $selection->get_selected;
  if (!defined $iter) {
    $self->display_results ($self->{parser}->format_namespace);
  } elsif (!$model->get ($iter, GIR_VIEW_COL_IS_CATEGORY)) {
    my $path = $model->get ($iter, GIR_VIEW_COL_PATH);
    $self->go_to_path ($path);
  }
}
sub go_to_path {
  my ($self, $path) = @_;
  my $name = $self->{parser}->format_node_name_by_path ($path);
  $self->{path_bar}->append ($name, $path); # indirectly calls update_results
}
sub update_results {
  my ($self, $path) = @_;
  $self->display_results ($self->{parser}->format_node_by_path ($path));
  # Show and select the correponding tree entry.
  $self->{gir_model}->foreach (sub {
    my ($model, $tree_path, $iter) = @_;
    my $this_path = $model->get ($iter, GIR_VIEW_COL_PATH);
    if (defined $this_path && $this_path eq $path) {
      $self->{gir_view}->expand_to_path ($tree_path);
      $self->{gir_view}->scroll_to_cell ($tree_path, undef, FALSE, 0.0, 0.0);
      $self->{suppress_gir_view_selection_changes} = TRUE;
      {
        $self->{gir_view}->get_selection ()->select_path ($tree_path);
      }
      $self->{suppress_gir_view_selection_changes} = FALSE;
      return TRUE; # stop
    }
    return FALSE; # continue
  });
}
sub quit {
  my ($self) = @_;
  Gtk3::main_quit ();
}
package PathBar;
# The BEGIN { eval } dance is to support not loading Gtk3 in text mode.
BEGIN { eval {use Glib::Object::Subclass qw/Gtk3::Box/;} }
sub TRUE () {1}
sub FALSE () {0}
sub INIT_INSTANCE {
  my ($self) = @_;
  my $back_button = Gtk3::Button->new;
  $back_button->set_image (
    Gtk3::Image->new_from_icon_name ('go-previous-symbolic', 'button'));
  $back_button->set_sensitive (FALSE);
  $back_button->signal_connect (clicked => sub { $self->{path_label}->go_back });
  my $forward_button = Gtk3::Button->new;
  $forward_button->set_image (
    Gtk3::Image->new_from_icon_name ('go-next-symbolic', 'button'));
  $forward_button->set_sensitive (FALSE);
  $forward_button->signal_connect (clicked => sub { $self->{path_label}->go_forward });
  my $nav_box = Gtk3::Box->new ('horizontal', 2);
  $nav_box->pack_start ($back_button, FALSE, FALSE, 0);
  $nav_box->pack_start ($forward_button, FALSE, FALSE, 0);
  $nav_box->get_style_context->add_class ('linked');
  my $path_label = PathLabel->new;
  $path_label->set_update_func (sub {
    my ($name, $path) = @_;
    $self->update_buttons;
    if (defined $self->{update_func}) {
      $self->{update_func}->($name, $path);
    }
  });
  $self->pack_start ($nav_box, FALSE, FALSE, 0);
  $self->pack_start (Gtk3::VSeparator->new, FALSE, FALSE, 0);
  $self->pack_start ($path_label, TRUE, TRUE, 0);
  $self->set (margin => 2);
  $self->{back_button} = $back_button;
  $self->{forward_button} = $forward_button;
  $self->{path_label} = $path_label;
  return $self;
}
sub clear {
  my ($self) = @_;
  $self->{path_label}->clear ();
  $self->update_buttons ();
}
sub append {
  my ($self, $name, $path) = @_;
  $self->{path_label}->append ($name, $path);
}
sub set_update_func {
  my ($self, $func) = @_;
  $self->{update_func} = $func;
}
sub update_buttons {
  my ($self) = @_;
  $self->{back_button}->set_sensitive ($self->{path_label}->can_go_back);
  $self->{forward_button}->set_sensitive ($self->{path_label}->can_go_forward);
}
package PathLabel;
# The BEGIN { eval } dance is to support not loading Gtk3 in text mode.
BEGIN { eval {use Glib::Object::Subclass qw/Gtk3::Label/;} }
sub TRUE () {1}
sub FALSE () {0}
sub INIT_INSTANCE {
  my ($self) = @_;
  $self->signal_connect (activate_link => sub {
    my (undef, $index) = @_;
    $self->{current_child} = $index;
    $self->update;
    return Gtk3::EVENT_STOP ();
  });
  $self->set_track_visited_links (FALSE);
  $self->clear ();
}
sub clear {
  my ($self) = @_;
  $self->{children} = [];
  $self->{current_child} = undef;
  $self->{natural_width} = 0;
  $self->update ();
}
sub append {
  my ($self, $name, $path) = @_;
  my $cur = $self->{current_child};
  # If the new entry is equal to the current entry, do nothing.
  if (defined $cur) {
    my $child = $self->{children}->[$cur];
    if ($child->{name} eq $name && $child->{path} eq $path) {
      return;
    }
  }
  # If the current entry is not the last entry, remove all entries after the
  # current one before appending the new entry.
  if (defined $cur && $cur < $#{$self->{children}}) {
    splice @{$self->{children}}, $cur+1;
  }
  push @{$self->{children}}, {name => $name, path => $path};
  $self->{current_child} = $#{$self->{children}};
  $self->update;
}
sub can_go_back {
  my ($self) = @_;
  return defined $self->{current_child} && $self->{current_child} > 0;
}
sub can_go_forward {
  my ($self) = @_;
  return defined $self->{current_child} && $self->{current_child} < $#{$self->{children}};
}
sub go_back {
  my ($self) = @_;
  return unless $self->{current_child} > 0;
  $self->{current_child}--;
  $self->update;
}
sub go_forward {
  my ($self) = @_;
  return unless $self->{current_child} < $#{$self->{children}};
  $self->{current_child}++;
  $self->update;
}
sub set_update_func {
  my ($self, $func) = @_;
  $self->{update_func} = $func;
}
sub update {
  my ($self) = @_;
  $self->set_markup ($self->_format_children);
  if (defined $self->{current_child} && defined $self->{update_func}) {
    my $child = $self->{children}->[$self->{current_child}];
    $self->{update_func}->($child->{name}, $child->{path});
  }
}
sub GET_PREFERRED_WIDTH {
  #say 'GET_PREFERRED_WIDTH';
  my ($self) = @_;
  (undef, $self->{natural_width}) = $self->SUPER::GET_PREFERRED_WIDTH;
  return (0, 0);
}
sub SIZE_ALLOCATE {
  #say 'SIZE_ALLOCATE';
  my ($self, $allocation) = @_;
  if ($self->{natural_width} > $allocation->{width}) {
    my @selected = ($self->{current_child});
    while (1) {
      my @candidates = @selected;
      if ($selected[0] > 0) {
        unshift @candidates, $selected[0]-1;
      }
      if ($selected[-1] < $#{$self->{children}}) {
        push @candidates, $selected[-1]+1;
      }
      $self->set_markup ($self->_format_children (@candidates));
      my ($ink_rect, $logical_rect) = $self->get_layout->get_extents;
      my $text_width = $logical_rect->{width}/Pango::SCALE ();
      if ($text_width > $allocation->{width}) {
        last;
      } else {
        @selected = @candidates;
      }
    }
    $self->set_markup ($self->_format_children (@selected));
  }
  $self->SUPER::SIZE_ALLOCATE ($allocation);
}
 # Use undef as an indicator for left-out children.
sub _add_omission_markers {
  my ($self, @indices) = @_;
  if (!@indices) {
    return @indices;
  }
  if ($indices[0] > 0) {
    unshift @indices, undef;
  }
  if ($indices[-1] < $#{$self->{children}}) {
    push @indices, undef;
  }
  return @indices;
}
sub _format_child {
  my ($self, $index) = @_;
  return '…' unless defined $index;
  my $name = $self->{children}->[$index]->{name};
  my $markup = $index == $self->{current_child}
    ? "<b>$name</b>"
    : "<a href='$index'>$name</a>";
  return $markup;
}
sub _format_children {
  my ($self, @indices) = @_;
  if (!@indices) {
    @indices = 0..$#{$self->{children}};
  }
  @indices = $self->_add_omission_markers (@indices);
  return join ' ▸ ', map { $self->_format_child ($_) } @indices;
}
__END__
HideShow 59 lines of Pod
=encoding utf8
  
=head1 NAME
  
perli11ndoc - view documentation of installed libraries bound using
Glib::Object::Introspection
  
=head1 ABSTRACT
  
perli11ndoc allows you to view Perl documentation for Glib libraries bound to
Perl using Glib::Object::Introspection. Glib::Object::Introspection uses the
gobject-introspection and libffi projects to dynamically create Perl bindings
for a wide variety of libraries. Examples include gtk+, webkit, libsoup and
many more. All libraries currently installed will be shown with Perl-specific
documentation and examples. Where Glib::Object::Introspection differs from the
C library, differences are pointed out and the Perl-specific interface is
defined.
  
=head1 DEPENDENCIES
perli11ndoc requires that XML::LibXML be installed to run. It also requires
that the corresponding C library headers be installed on the system to provide
documentation. For instance, on a Debian-based system you would need
libgtk-3-dev to see the Perl introspected documentation for Gtk3.
=head1 SEE ALSO
  
=over
  
=item perl-Glib: L<Glib>
  
=item gobject-introspection: L<http://live.gnome.org/GObjectIntrospection>
  
=item libffi: L<http://sourceware.org/libffi/>
=item Glib::Object::Introspection: L<https://metacpan.org/pod/Glib::Object::Introspection>
  
=back
  
=head1 AUTHORS
  
=over
  
=item Emmanuele Bassi <ebassi at linux intel com>
  
=item muppet <scott asofyet org>
  
=item Torsten Schönfeld <kaffeetisch at gmx de>
  
=back
  
=head1 LICENSE
  
This utility is free software; you can redistribute it and/or modify it under
the terms of the Lesser General Public License (LGPL).  For more information,
see http://www.fsf.org/licenses/lgpl.txt
  
=cut