view release on metacpan or  search on metacpan

ccc/IR.pm  view on Meta::CPAN

#--------------------------------------------------------------------
sub export_to_DIA_by_id {
  my ($self, $repoid) = @_;
  my $entry = $self->{'ROOT'}->entry_by_id($repoid);
  if( not defined($entry) ) {
    CORBA::MICO::Misc::warning("Can't find interface for $repoid");
  }
  else {
    $self->export_to_DIA($entry->name(), $entry);
  }
}

#--------------------------------------------------------------------
# Show inheritance for an interface
# In: $name          - name of interface
#     $ir_node       - corresponding IR node object
#--------------------------------------------------------------------
sub show_inheritance {
  my ($self, $name, $ir_node) = @_;
  if( $ir_node->kind() eq 'dk_Interface' ) {
    show_interface_tree($name, [$ir_node]);
  }
  elsif( $ir_node->kind() eq 'dk_Module' ) {
    show_interface_tree($name, $ir_node->contents('dk_Interface'));
  }
}

#--------------------------------------------------------------------
# Show inheritance for an interface by repoid
# In: $repoid        - repoid of interface
#--------------------------------------------------------------------
sub show_inheritance_by_id {
  my ($self, $repoid) = @_;
  my $entry = $self->{'ROOT'}->entry_by_id($repoid);
  if( not defined($entry) ) {
    CORBA::MICO::Misc::warning("Can't find interface for $repoid");
  }
  else {
    $self->show_inheritance($entry->name(), $entry);
  }
}

#--------------------------------------------------------------------
# Prepare widgets, internal data, start timeout handler
# In: $root_ir   - IRRoot
#     $topwindow - toplevel widget
#     $sline     - status line widget
#     $bg_sched  - background processing scheduler
#     $menu       - main menu object
#--------------------------------------------------------------------
sub init_browser {
  my ($self, $root_ir, $topwindow, $sline, $bg_sched, $menu) = @_;
  
  # Determine MICO version
  my $ai = $root_ir->entry_by_id('IDL:omg.org/CORBA/AbstractInterfaceDef:1.0');
  my $is_235 = not $ai;

  # Vertical box: pane
  my $vbox = new Gtk2::VBox;

  # Menu
  my $menu_id = "IR_$serial"; ++$serial;
  $menu->add_item($menu_id, $menu_item_IDL,
                            undef, \&show_IDL_cb, $self);
  $menu->add_item($menu_id, $menu_item_iheritance,
                            undef, \&show_inheritance_cb, $self);
  $menu->add_item($menu_id, $menu_item_DIA,
                            undef, \&export_to_DIA_cb, $self);
  $menu->add_item($menu_id, $menu_item_search,
                            '<control>F', \&search_cb, [$self, 0]);
  $menu->add_item($menu_id, $menu_item_search_re,
                            '<control>R', \&search_cb, [$self, 1]);
  $menu->add_item($menu_id, $menu_item_expand_all,
                            undef, \&expand_all_cb, $self);
  # Create paned window: left-tree, right-text
  my $paned = new Gtk2::HPaned;
  $vbox->pack_start($paned, 1, 1, 0);
  $vbox->show_all();

  # Create scrolled window for CTree
  my $scrolled = new Gtk2::ScrolledWindow(undef,undef);
  $scrolled->set_policy( 'automatic', 'automatic' );
  $paned->add($scrolled);

  # Create ctree widget (use Gtk2::TreeView instead of Gtk::CTree)
  my $model = Gtk2::TreeStore->new('Glib::String', 'Glib::Scalar');
  my $ctree = Gtk2::TreeView->new;
  $ctree->set_model($model);
  my $selection = $ctree->get_selection;
  $selection->set_mode ('browse');
  my $cell = Gtk2::CellRendererText->new;
  my $column = Gtk2::TreeViewColumn->new_with_attributes('',
                              $cell, 'text' => TREE_TITLE_COLUMN);
  $ctree->append_column($column);
  # disable incremental search
  $ctree->set_enable_search(0);
  # search by regexp
  $ctree->set_search_equal_func(\&CORBA::MICO::Misc::ctree_std_search, $self);
  # and use popup search via CTRL_F/CTRL_R
  #$ctree->signal_connect(
  #               key_press_event => \&CORBA::MICO::Misc::ctree_kpress, $self);

  $scrolled->add($ctree);

  # Create text window for IDL-representation of selected items
  my $hptext = CORBA::MICO::Hypertext::hypertext_create(1);
  $paned->add2($hptext);

  $paned->set_position(200);
  $scrolled->show();
  $ctree->show();
  $paned->show();
  $bg_sched->add_entry($self);
  $ctree->signal_connect('destroy',
                     sub { $self->close();$bg_sched->remove_entry($self); 1; });
  $selection->signal_connect(changed => \&row_selected, $self);
  $ctree->signal_connect(row_expanded => \&row_expanded, $self);
  $ctree->signal_connect(row_activated => \&row_activated, $self);

  $self->{'TOPWINDOW'} = $topwindow;    # toplevel window
  $self->{'SLINE'}     = $sline;        # status line

ccc/IR.pm  view on Meta::CPAN

  $dialog->realize();
}

#--------------------------------------------------------------------
# Export interface inheritance tree to DIA
#--------------------------------------------------------------------
sub export_to_dia {
  my ($name, $nodes) = @_;
  return unless @$nodes;
  my ($fname) = $name =~ /.*:(.*)/;
  CORBA::MICO::Misc::select_file("Export $name to DIA",
                   "${fname}.xml", 0,
                   sub { CORBA::MICO::IR2Dia::dump_interface($_[0], $nodes) } );
}

#--------------------------------------------------------------------
# Get contained objects.
# Args: $ir_node - IRRoot object
#       (types)  - types of 'Contained' objects should be retrieved
#--------------------------------------------------------------------
sub ir_contents {
  my $ir_node = shift;
  my @retval = ();
  foreach my $type (@_) {
    my $contents = $ir_node->contents($type, 1);
    push (@retval, @$contents);
  }
  return \@retval;
}

#--------------------------------------------------------------------
# Prepare some internal data for callback and call callback handler
# In: $curs_watch - change cursoe to watch if TRUE
#     $callback   - callback handler, must expect parameters:
#                   $self
#                   $name     - name of IR entry
#                   $ir_node  - IR entry object
#                   @cb_parms - the rest of our parameters
#     @cb_parms   - additional parameters will be passed to callback handler
#--------------------------------------------------------------------
sub call_menu_callback {
  my ($self, $curs_watch, $callback, @cb_parms) = @_;
  my $ctree = $self->{'CTREE'};
  my $topwindow = $self->{'TOPWINDOW'};
  my $selected_node = $self->{'NODE'};
  return unless defined($selected_node);
  my $model = $self->{'MODEL'};
  my ($desc, $ud) = $model->get($selected_node,
                                TREE_TITLE_COLUMN,
                                TREE_UDATA_COLUMN);
  my $ir_node = $ud->[0];
  return unless defined $ir_node;
  my $name = $ir_node->name();
  $self->{'IR_ITEMS'}->{$name} = $ir_node;
  return if $curs_watch and CORBA::MICO::Misc::cursor_watch($topwindow, 1);
  &{$callback}($self, $name, $ir_node, @cb_parms);
  $curs_watch and CORBA::MICO::Misc::cursor_restore_to_default($topwindow, 0);
}

#--------------------------------------------------------------------
# Menu item activated: show IDL
#--------------------------------------------------------------------
sub show_IDL_cb {
  my $self = shift;
  $self->call_menu_callback(
           1,           # cursor watch
           sub {        # show IDL
             my ($self, $name) = @_;
             $self->show_IDL($name);
           }
  );
}

#--------------------------------------------------------------------
# Menu item activated: show tree of inheritance
#--------------------------------------------------------------------
sub show_inheritance_cb {
  my $self = shift;
  $self->call_menu_callback(
           1,           # cursor watch
           sub {        # show inheritance
             my ($self, $name, $ir_node) = @_;
             $self->show_inheritance($name, $ir_node);
           }
  );
}

#--------------------------------------------------------------------
# Menu item activated: export tree of inheritance to DIA
#--------------------------------------------------------------------
sub export_to_DIA_cb {
  my $self = shift;
  $self->call_menu_callback(
           0,           # no cursor watch
           sub {        # export tree of inheritance to DIA
             my ($self, $name, $ir_node) = @_;
             $self->export_to_DIA($name, $ir_node);
           }
  );
}

#--------------------------------------------------------------------
# Menu item activated: expand all
#--------------------------------------------------------------------
sub expand_all_cb {
  my $self = shift;
  $self->{CTREE}->expand_all();
}

#--------------------------------------------------------------------
# Menu item activated: find/find regexp
#--------------------------------------------------------------------
sub search_cb {
  my $ud = shift;
  my ($self, $is_regexp) = @$ud;
  $self->{REGEXP} = $is_regexp;

  if( $self->{CTREE}->has_focus() ) {
    $self->{CTREE}->signal_emit('start_interactive_search');
  }
  else {
    CORBA::MICO::Hypertext::do_search($self->{TEXT}, $is_regexp);
  }
}

#--------------------------------------------------------------------
# Pre/post callback for hypertext
sub htprepost_cb {
  my ($self, $pre) = @_;
  $self->{NOIDL} = $pre;
  mask_menu($self);
}

#--------------------------------------------------------------------
# Enable/disable menu choices according to type of selected IR object
sub mask_menu {
  my $self = shift; 
  my ($idl_ok, $inher_ok) = (0, 0);
  my $selected_node = $self->{'NODE'};
  my $model = $self->{'MODEL'};
  my $menu = $self->{'MENU'};
  if( defined($selected_node) ) {
   my ($desc, $ud) = $model->get($selected_node, 
                                 TREE_TITLE_COLUMN,
                                 TREE_UDATA_COLUMN);
    my $ir_node = $ud->[0];
    if( defined($ir_node) ) {
      $idl_ok = !$self->{NOIDL};
      my $kind = $ir_node->kind();
      if( $kind eq 'dk_Interface' or $kind eq 'dk_Module') {
        $inher_ok = 1;
      }
    }
  }
  $menu->mask_item($menu_item_IDL, $idl_ok);
  $menu->mask_item($menu_item_iheritance, $inher_ok);
  $menu->mask_item($menu_item_DIA, $inher_ok);
}

#--------------------------------------------------------------------
sub close {
  warn "IR::close()" if $DEBUG;
  my $self = shift;
  foreach my $k (keys %$self) {
    $self->{$k} = undef;
  }
}

#--------------------------------------------------------------------
sub DESTROY {
  my $self = shift;