%PDF-
%PDF-
Mini Shell
Mini Shell
| Direktori : /bin/X11/X11/ |
|
|
|
| Current File : //bin/X11/X11/perli11ndoc |
#!/usr/bin/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__
=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
Zerion Mini Shell 1.0