ir-browser/browser - metacpan.org

#!/usr/bin/perl -w

use Gtk;
use CORBA::MICO;
use Error qw(:try);

use TCUtils;

use strict;

sub FALSE { 0 };
sub TRUE { 1 };

Gtk->init;

# Global variables

my $leftside;
my $leftside_child;
my $ir;

# Pixmaps

my $book_open;
my $book_open_mask;
my @book_open_xpm = (
"16 16 4 1",
"       c None s None",
".      c black",
"X      c #808080",
"o      c white",
"                ",
"  ..            ",
" .Xo.    ...    ",
" .Xoo. ..oo.    ",
" .Xooo.Xooo...  ",
" .Xooo.oooo.X.  ",
" .Xooo.Xooo.X.  ",
" .Xooo.oooo.X.  ",
" .Xooo.Xooo.X.  ",
" .Xooo.oooo.X.  ",
"  .Xoo.Xoo..X.  ",
"   .Xo.o..ooX.  ",
"    .X..XXXXX.  ",
"    ..X.......  ",
"     ..         ",
"                ");

my $book_closed;
my $book_closed_mask;
my @book_closed_xpm = (
"16 16 6 1",
"       c None s None",
".      c black",
"X      c red",
"o      c yellow",
"O      c #808080",
"#      c white",
"                ",
"       ..       ",
"     ..XX.      ",
"   ..XXXXX.     ",
" ..XXXXXXXX.    ",
".ooXXXXXXXXX.   ",
"..ooXXXXXXXXX.  ",
".X.ooXXXXXXXXX. ",
".XX.ooXXXXXX..  ",
" .XX.ooXXX..#O  ",
"  .XX.oo..##OO. ",
"   .XX..##OO..  ",
"    .X.#OO..    ",
"     ..O..      ",
"      ..        ",
"                ");

my $mini_page;
my $mini_page_mask;
my @mini_page_xpm = (
"16 16 4 1",
"       c None s None",
".      c black",
"X      c white",
"o      c #808080",
"                ",
"   .......      ",
"   .XXXXX..     ",
"   .XoooX.X.    ",
"   .XXXXX....   ",
"   .XooooXoo.o  ",
"   .XXXXXXXX.o  ",
"   .XooooooX.o  ",
"   .XXXXXXXX.o  ",
"   .XooooooX.o  ",
"   .XXXXXXXX.o  ",
"   .XooooooX.o  ",
"   .XXXXXXXX.o  ",
"   ..........o  ",
"    oooooooooo  ",
"                ");

my $dummy_win;

sub create_pixmap {
    my $data = shift;
    
    if (!defined $dummy_win) {
	$dummy_win = Gtk::Window->new('toplevel');
	$dummy_win->realize;
    }

    return Gtk::Gdk::Pixmap->create_from_xpm_d($dummy_win->window, 
					       undef, 
					       @$data);
}

($book_open, $book_open_mask) = create_pixmap (\@book_open_xpm);
($book_closed, $book_closed_mask) = create_pixmap (\@book_closed_xpm);
($mini_page, $mini_page_mask) = create_pixmap (\@mini_page_xpm);
    
sub create_row {
    my ($table, $row, $ltext, $text) = @_;

    my $label = Gtk::Label->new($ltext);
    $label->set_alignment (1.0, 0.5);
    $table->attach($label, 0, 1, $row, $row+1, ["fill"], [], 0, 0);
    $label = Gtk::Label->new($text);
    $label->set_alignment (0.0, 0.5);
    $table->attach($label, 1, 2, $row, $row+1, ["expand", "fill"], [], 0, 0);
}

sub create_generic {
    my ($ir_node, $extra_rows) = @_;

    defined $extra_rows or $extra_rows = 0;
    
    my $result = Gtk::VBox->new (0, 5);

    my $table = Gtk::Table->new (3 + $extra_rows, 2, 0);
    $table->set_col_spacings (5);
    
    $result->pack_start ($table, 0, 0, 0);

    my ($kind) = $ir_node->_get_def_kind =~ /dk_(.*)/;
    create_row ($table, 0, "Kind:", $kind);

    my ($name) = $ir_node->_get_absolute_name =~ /:*(.*)/;
    create_row ($table, 1, "Name:", $name);

    my $repoid = $ir_node->_get_id;
    create_row ($table, 2, "RepoID:", $repoid);

    $table->show_all;

    $result->{table} = $table;

    return $result;
}

sub create_text {
    my $string = shift;
    
    my $sw = Gtk::ScrolledWindow->new ();
    $sw->set_policy ('automatic', 'automatic');

    my $color = Gtk::Gdk::Colormap->get_system->color_black ();
    my $font = Gtk::Gdk::Font->load ("-b&h-lucidatypewriter-bold-r-normal-*-*-120-*-*-*-*-iso8859-1");

    my $text = Gtk::Text->new;
    $sw->add ($text);
    $text->show;

    $text->insert ($font, $color, undef, $string);

    return $sw;
}

sub create_struct_exception {
    my ($ir_node, $keyword) = @_;

    
    my $retval = create_generic ($ir_node, 0);

    my $str = join ('',
		    "$keyword ", $ir_node->_get_name, " {\n",
		    (map {
			 ("    ".
			  stringify_tc ($ir, $_->{type}, "    ").
			  " $_->{name};\n");
		     } @{$ir_node->_get_members}),
		    "}");

    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_struct {
    my ($ir_node) = shift;

    create_struct_exception ($ir_node, "struct");
}

sub create_exception {
    my ($ir_node) = shift;

    create_struct_exception ($ir_node, "exception");
}

sub create_interface {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);

    my $str = "interface ".$ir_node->_get_name;
    
    my $bases = $ir_node->_get_base_interfaces;
    if (@$bases) {
	$str .= ": ";
	$str .= join ((",\n".(' ' x length($str))), map {
	    my ($name) = $_->_get_absolute_name =~ /:*(.*)/;
	    $name;
	} @$bases);
    }

    $str .= "\n    {...}";
    
    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_attribute {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);
    
    my $str = join ('', 
		    ($ir_node->_get_mode eq 'ATTR_READONLY') ? "readonly " : "",
		    "attribute ",
		    stringify_tc ($ir, $ir_node->_get_type),
		    " ",
		    $ir_node->_get_name);

    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_constant {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);
    
    my $str = join ('', "const ", 
		    stringify_tc ($ir, $ir_node->_get_type),
		    " ", 
		    $ir_node->_get_name,
		    " = ",
		    $ir_node->_get_value->value);

    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_enum {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);

    my $str = "enum ".$ir_node->_get_name." {\n".
	    join (",\n", map { "    $_" } @{$ir_node->_get_members}).
	    "\n}";

    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_alias {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);
    
    my $str = join ('', "typedef ", 
		    stringify_tc ($ir, $ir_node->_get_original_type_def->_get_type),
		    " ", 
		    $ir_node->_get_name);

    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

sub create_operation {
    my ($ir_node) = shift;

    my $retval = create_generic ($ir_node, 0);

    my $maxlen = 0;
    my (@types, @names);
    
    for my $param (@{$ir_node->_get_params}) {
	my $t = stringify_tc ($ir, $param->{type});
	push @types, $t;
	$maxlen = length ($t) if length ($t) > $maxlen;

	push @names, $param->{name};
    }

    for my $t (@types) {
	$t = $t.(' ' x ($maxlen - length($t)))." ".(shift @names);
    }

    my $tc = $ir_node->_get_result_def->_get_type;
    my $str = join ('', 
		    stringify_tc ($ir, $ir_node->_get_result_def->_get_type),
		    " ", $ir_node->_get_name," (");

    my $indent = length($str);
    if (@types) {
	$str .= shift @types;
    }
    for my $t (@types) {
	$str .= "\n" . (' ' x $indent) . $t;
    }
    $str  .= ")\n"; 
    
    $retval->pack_start (create_text ($str), TRUE, TRUE, 0);

    $retval->show_all;
    return $retval;
}

my %parents = (
	      'dk_Exception'  => \&create_exception,
	      'dk_Interface'  => \&create_interface,
	      'dk_Module'     => \&create_generic,
	      'dk_Repository' => \&create_generic,
	      'dk_Struct'     => \&create_struct,
	      'dk_Union'      => \&create_generic,
	      'dk_Value'      => \&create_generic
	      );

my %leaves = (
	      'dk_Attribute'   => \&create_attribute,
	      'dk_Constant'    => \&create_constant,
	      'dk_Operation'   => \&create_operation,
	      'dk_Typedef'     => \&create_generic,
	      'dk_Alias'       => \&create_alias,
	      'dk_Enum'        => \&create_enum,
	      'dk_Primitive'   => \&create_generic,
	      'dk_String'      => \&create_generic,
	      'dk_Sequence'    => \&create_generic,
	      'dk_Array'       => \&create_generic,
	      'dk_Repository'  => \&create_generic,
	      'dk_WString'     => \&create_generic,
	      'dk_Fixed'       => \&create_generic,
	      'dk_Value'       => \&create_generic,
	      'dk_ValueBox'    => \&create_generic,
	      'dk_ValueMember' => \&create_generic,
	      'dk_Native'      => \&create_generic
	      );

sub row_selected {
    my ($ctree, $row, $column) = @_;
    my $repoid = $ctree->get_text($row, 1);

    $leftside_child->destroy if defined $leftside_child;
    undef $leftside_child;
    
    my $ir_node = $ir->lookup_id ($repoid);
    return unless defined $ir_node;

    my $defkind = $ir_node->_get_def_kind;

    if (defined $parents{$defkind}) {
	$leftside_child = $parents{$defkind}->($ir_node);
    } elsif (defined $leaves{$defkind}) {
	$leftside_child = $leaves{$defkind}->($ir_node);
    }

    if (defined $leftside_child) {
	$leftside_child->show;
	$leftside->add ($leftside_child);
    }
};

sub build_tree {
    my ($ctree, $parent, $ir_node, $name) = @_;

    my $defkind = $ir_node->_get_def_kind;
    my $contents;
    
    if (exists $parents{$defkind}) {
	$contents = $ir_node->contents("dk_all", 1);
    } else {
	$contents = [];
    }

    my $id;
    if ($defkind eq "dk_Repository") {
	$id = "";
    } else {
	$id = $ir_node->_get_id;
    }
    
    my $node;
    if ($#$contents >= 0) {
	$node = $ctree->insert_node ($parent, undef, [ $name, $id ], 5, 
				     $book_closed, $book_closed_mask, 
				     $book_open, $book_open_mask, 
				     0, !defined $parent);
    } else {
	$node = $ctree->insert_node ($parent, undef, [ $name, $id ], 5, 
				     $mini_page, $mini_page_mask,
				     undef, undef,
				     1, 0);
    }
    
    for my $child (@$contents) {
	my $child_name = $child->_get_name;
	build_tree ($ctree, $node, $child, $child_name);
    }
}

my $orb = CORBA::ORB_init("mico-local-orb");
$ir = $orb->resolve_initial_references ("InterfaceRepository");

my $window = new Gtk::Window('toplevel');

my $vbox = Gtk::VBox->new (0, 0);
$window->add($vbox);

#
# Menu
#
my $mi;

my $mb = Gtk::MenuBar->new ();
$vbox->pack_start ($mb, FALSE, FALSE, 0);

$mi = Gtk::MenuItem->new("File");
$mb->append ($mi);

  my $menu = Gtk::Menu->new ();
  $mi->set_submenu ($menu);

  $mi = Gtk::MenuItem->new("Quit");
  $menu->append ($mi);

  $mi->signal_connect ('activate', sub { Gtk->main_quit });

my $paned = Gtk::HPaned->new();
$vbox->pack_start ($paned, TRUE, TRUE, 0);

my $sw = Gtk::ScrolledWindow->new ();
$sw->set_policy ('automatic', 'automatic');

$paned->add1 ($sw);

$leftside = Gtk::VBox->new (0, 0);
$leftside->set_border_width (5);
$paned->add2 ($leftside);
$paned->set_position (200);

my $ctree = Gtk::CTree->new (2, 0);
$ctree->set_selection_mode ('browse');
$ctree->set_column_auto_resize (0, 1);
$ctree->set_column_visibility (1, 0);
$sw->add ($ctree);
$ctree->signal_connect ('select_row', \&row_selected);
build_tree ($ctree, undef, $ir, "(Repository)");

$window->set_default_size (600, 400);
$window->show_all;

Gtk->main;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)