view release on metacpan or  search on metacpan

ccc/IR.pm  view on Meta::CPAN

#--------------------------------------------------------------------
# Signal handler: CTree row selected
# args: $selection, $self
#--------------------------------------------------------------------
sub row_selected {
  my ($selection, $self) = @_;

  my $iter = $selection->get_selected();
  $self->{'NODE'} = $iter;
  $self->mask_menu();
}

#--------------------------------------------------------------------
# Signal handler: CTree row activated: just show IDL
# args: $ctree, $iter, $path, $column, $self
#--------------------------------------------------------------------
sub row_activated {
  my ($ctree, $path, $column, $self) = @_;
  show_IDL_cb($self);
}

#--------------------------------------------------------------------
# Signal handler: CTree row is to be expanded
# args: $ctree, $iter, $path, $self
#--------------------------------------------------------------------
sub row_expanded {
  my ($ctree, $iter, $path, $self) = @_;
  return expand_row($self, $iter);
}

#--------------------------------------------------------------------
# Insert buffered nodes directly to the CTree
#--------------------------------------------------------------------
sub insert_buffered {
  my ($self, $ctree, $parent, $buffered) = @_;
  my $node = add_tree_node($self, $ctree, $parent, 
                           $buffered->{'DESC'},
                           $buffered->{'IS_LEAF'},
                           $buffered->{'DATA'});
  foreach my $bchild (@{$buffered->{'CHILDREN'}}) {
    insert_buffered($self, $ctree, $node, $bchild);
  }
}

#--------------------------------------------------------------------
# Insert corresponding subnodes to a node if there are some ones
# not inserted yet
#--------------------------------------------------------------------
sub expand_row {
  my ($self, $node) = @_;
  my $ctree = $self->{'CTREE'};
  my $queue = $self->{'BG_QUEUE'};
  my $topwindow = $self->{'TOPWINDOW'};
  my $model = $self->{'MODEL'};
  my ($desc, $ud) = $model->get($node,
                                TREE_TITLE_COLUMN,
                                TREE_UDATA_COLUMN);
  my $contents = $ud->[1];
  my $buffered = $ud->[2];
  return 1 unless defined($contents) or defined($buffered);
  return 1 if CORBA::MICO::Misc::cursor_watch($topwindow, 1);
  $ctree->hide();
  if( defined($buffered) ) {
    # insert buffered subnodes (if any)
    foreach my $b (@$buffered) {
      insert_buffered($self, $ctree, $node, $b);
    }
    $ud->[2] = undef;
  }
  if( defined($contents) ) {
    # insert new (unbuffered) subnodes (if any) into CTree
    my $ir_node = $ud->[0];
    create_subtree($ctree, $node, $contents, $queue, $self);
    $ud->[1] = undef;   # mark node as fully constructed
  }
  CORBA::MICO::Misc::cursor_restore_to_default($topwindow, 0);
  $ctree->show();
}

#--------------------------------------------------------------------
# Hypertext handler
# args: item_name, %ir_items
# Returns a list of lines to be shown
sub hypertext_cb {
  my ($name, $self) = @_;
  my $root_ir = $self->{'ROOT'};
  my $items = $self->{'IR_ITEMS'};
  my $ir_node = $root_ir->entry($name);
  my @retval = ("#pragma ID $name \"" . $ir_node->repoid() . '"');
  push(@retval, @{prepare_text($self, $ir_node, $name, $items)});
  return \@retval;
}

#--------------------------------------------------------------------
# Prepare a human-readable representation of IR object to be
# shown in right side text window
#--------------------------------------------------------------------
sub prepare_text {
  my($self, $ir_node, $name, $items) = @_;
  my $entry = $ir_nodes{ $ir_node->kind() };
  return undef unless defined($entry);
  my $desc = &{$entry->[0]}($ir_node->ir_node(), $name, $items, $self);
  if( $entry->[1] ) {
#     container  
    my $contents = $ir_node->contents("dk_all");
    if( $#$contents >= 0 ) {
      foreach my $c (@$contents) {
        my $child_desc = prepare_text($self, $c, $c->shname(), $items);
        push(@$desc, @$child_desc);
      }
    }
  }
  if( @$desc > 1 ) {
    # post-process compound IR object
    $desc->[0] .= " {";
    for( my $i = 1; $i < @$desc; ++$i ) {
      $desc->[$i] =~ s/^/  /;
    }
    push( @$desc, "};" );
  }
  return $desc;
}

#--------------------------------------------------------------------
# Show interface inheritance tree via CORBA::MICO::Pixtree
#--------------------------------------------------------------------
sub show_interface_tree {
  my ($name, $nodes) = @_;
  return unless @$nodes;
  my $dialog = new Gtk2::Window('toplevel');
  $dialog->set_default_size(400, 200);
  $dialog->set_position('mouse');
  my $pixtree = CORBA::MICO::Pixtree::pixtree_create();
  CORBA::MICO::Pixtree::pixtree_show($pixtree, $nodes);
  $dialog->set_title($name);
  $dialog->add($pixtree->[0]);
  $dialog->show_all();
  $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;
      }
    }
  }