validate results from the CPAN

App-Chart

    }
  }

  $self->{'mlist'} = \@mlist;
  $self->{'n_columns'} = $n_columns;
  $self->{'column_types'} = \@column_types;

  if (DEBUG) {
    local $, = ' ';
    print "  column_types",@column_types,"\n";
  }
}

# gtk_tree_model_get_flags
#
sub GET_FLAGS {
  return [];
}

# gtk_tree_model_get_n_columns
#
sub GET_N_COLUMNS {
  my ($self) = @_;
  if (DEBUG >= 2) { print "ListOfListsModel get_n_columns\n"; }
  return $self->{'n_columns'};
}

# gtk_tree_model_get_column_type
#
sub GET_COLUMN_TYPE {
  return $_[0]->{'column_types'}->[$_[1]];
}

# gtk_tree_model_get_iter
#
sub GET_ITER {
  my ($self, $path) = @_;
  if (DEBUG >= 2) { print "ListOfListsModel get_iter, path='",
                      $path->to_string,"'\n"; }
  my $depth = $path->get_depth;
  $self->{'list_model'} || return undef; # when no models
  my ($top_index, $sub_index) = $path->get_indices;

  if ($depth == 1) {
    # top-level
    return [ $self->{'stamp'}, $top_index, undef, undef ];
  }
  if ($depth == 2) {
    # sub-list
    my $minfo = $self->{'mlist'}->[$top_index] || return undef;
    return [ $self->{'stamp'}, $sub_index, $minfo, undef ];
  }
  return undef;
}

# gtk_tree_model_get_path
#
sub GET_PATH {
  my ($self, $iter) = @_;
  if (DEBUG >= 2) { print "ListOfListsModel get_path\n"; }
  my ($index, $minfo) = _iter_validate ($self, $iter);
  if (defined $minfo) {
    my $mnum = $minfo->{'mnum'};
    return Gtk2::TreePath->new_from_indices ($mnum, $index);
  } else {
    return Gtk2::TreePath->new_from_indices ($index);
  }
}

# gtk_tree_model_get_value
#
sub GET_VALUE {
  my ($self, $iter, $col) = @_;
  if (DEBUG >= 2) { print "ListOfListsModel get_value\n";
                    print "  iter=",$iter->[0],",",$iter->[1],",",
                      defined $iter->[2] ? $iter->[2] : 'undef',
                        " col=$col\n"; }

  my ($index, $minfo) = _iter_validate ($self, $iter);
  my $list_model_n_columns = $self->{'list_model_n_columns'};
  my $model;

  if ($col < $list_model_n_columns) {
    # columns of list_model
    $model = $self->{'list_model'} || return undef;
    if ($minfo) {
      # $iter is a submodel row
      $index = $minfo->{'mnum'};
    }

  } else {
    # columns of submodels
    if (! $minfo) {
      if (DEBUG >= 2) { print "  submodel col empty in toplevel row\n"; }
      return;
    }
    $col -= $list_model_n_columns;
    $model = $minfo->{'model'} || return undef;
    if (DEBUG >= 2) { print "  submodel adj col=$col\n"; }
  }

  my $subiter = $model->iter_nth_child(undef,$index) || do {
    if (DEBUG >= 2) { print "  cannot get subiter $model index=$index\n"; }
    return undef;
  };
  return $model->get_value ($subiter, $col);
}

# gtk_tree_model_iter_next
#
sub ITER_NEXT {
  my ($self, $iter) = @_;
  if (DEBUG >= 2) { print "ListOfListsModel iter_next\n"; }
  my ($index, $minfo) = _iter_validate ($self, $iter);

  $index++;
  if ($minfo) {
    # next in submodel
    my $model = $minfo->{'model'} || return undef;
    if ($index < $model->iter_n_children(undef)) {
      return [ $self->{'stamp'}, $index, $minfo, undef ];
    }

  } else {
    # next in toplevel
    if ($index < scalar @{$self->{'mlist'}}) {
      return [ $self->{'stamp'}, $index, undef, undef ];
    }
  }
  return undef;
}

# gtk_tree_model_iter_children
#
sub ITER_CHILDREN {
  my ($self, $iter) = @_;
  if (DEBUG) { print "ListOfListsModel iter_children\n"; }
  return ITER_NTH_CHILD ($self, $iter, 0);
}

# gtk_tree_model_iter_has_child
#
sub ITER_HAS_CHILD {
  my ($self, $iter) = @_;
  if (DEBUG) { print "ListOfListsModel has_child ",$iter->[1],"\n"; }

  # Note: prior to Gtk2-Perl 1.190 the return had to be a number, not any
  # old boolean
  return ITER_N_CHILDREN($self,$iter) != 0;
}

# gtk_tree_model_iter_n_children
#
sub ITER_N_CHILDREN {
  my ($self, $iter) = @_;
  if (DEBUG) { print "ListOfListsModel iter_n_children\n"; }

  if (! defined $iter) {
    # asking about top-levels
    if (DEBUG) { print "  toplevel has ",scalar @{$self->{'mlist'}},"\n"; }
    return scalar @{$self->{'mlist'}};
  }
  my ($index, $minfo) = _iter_validate ($self, $iter);

  if ($minfo) {
    # asking about under submodel
    if (DEBUG) { print "  nothing under submodel rows\n"; }
    return 0;
  } else {
    # asking about under toplevel row
    $minfo = $self->{'mlist'}->[$index] || return 0;
    my $model = $minfo->{'model'} || return 0;
    if (DEBUG) { print "  model row has",$model->iter_n_children(undef),"\n"; }
    return $model->iter_n_children(undef);
  }
}

# gtk_tree_model_iter_nth_child
#
sub ITER_NTH_CHILD {
  my ($self, $iter, $n) = @_;
  if (DEBUG) { print "ListOfListsModel iter_nth_child",
                 " index=",$iter?$iter->[1]:'<iter undef>',
                   " minfo=",($iter&&$iter->[2])||'undef',
                     " child n=$n\n"; }

  my $mlist = $self->{'mlist'};
  if (defined $iter) {
    my ($index, $minfo) = _iter_validate ($self, $iter);
    if (! $minfo) {
      # $n'th row of model under toplevel $index
      if ($minfo = $mlist->[$index]) {
        if (my $model = $minfo->{'model'}) {
          if ($n < $model->iter_n_children(undef)) {
            if (DEBUG) { print "  yes, submodel $model row $n\n"; }
            return [ $self->{'stamp'}, $n, $minfo, undef ];
          }
        }
      }
    }
  } else {
    # $n'th row of top-level
    if ($n < @$mlist) {
      if (DEBUG) { print "  yes, toplevel row $n\n"; }
      return [ $self->{'stamp'}, $n, undef, undef ];
    }
  }
  if (DEBUG) { print "  no\n"; }
  return undef;
}

# gtk_tree_model_iter_parent
#
sub ITER_PARENT {
  my ($self, $iter) = @_;
  if (DEBUG) { print "ListOfListsModel iter_parent\n"; }

  my ($index, $minfo) = _iter_validate ($self, $iter);
  if (defined $minfo) {
    if (DEBUG) { print "  yes, up to toplevel ",$minfo->{'mnum'},"\n"; }
    return [ $self->{'stamp'}, $minfo->{'mnum'}, undef, undef ];
  }
  if (DEBUG) { print "  no\n"; }
  return undef;
}

# gtk_tree_model_ref_node
# gtk_tree_model_unref_node


#------------------------------------------------------------------------------
# our iters

# return ($mnum, $minfo), with $minfo undef on toplevel rows
sub _iter_validate {
  my ($self, $iter) = @_;
  if ($iter->[0] != $self->{'stamp'}) {
    croak "iter is not for this ", ref($self),
      " (stamp ", $iter->[0], " want ", $self->{'stamp'}, ")\n";
  }
  return ($iter->[1], $iter->[2]);
}

sub _top_index_to_iterobj {
  my ($self, $mnum) = @_;
  return Gtk2::TreeIter->new_from_arrayref ([ $self->{'stamp'}, $mnum, undef, undef ]);
}

sub _sub_index_to_iterobj {
  my ($self, $minfo, $index) = @_;
  return Gtk2::TreeIter->new_from_arrayref ([ $self->{'stamp'}, $index, $minfo, undef]);
}

sub _iterobj_validate {
  my ($self, $iterobj) = @_;
  if (! defined $iterobj) {
    croak 'iter is undef';
  }
  my $iter = Gtk2::TreeIter->to_arrayref ($self->{'stamp'});
  return ($iter->[1], $iter->[2]);
}


#------------------------------------------------------------------------------
# 'list_model' toplevel signals

# 'row-changed' on the toplevel list-model
#
sub _do_toplevel_row_changed {
  my ($model, $path, $subiter, $ref_weak_self) = @_;
  my $self = $$ref_weak_self || return;
  if (DEBUG) { print "ListOfListsModel toplevel row_changed handler\n";}
  if ($path->get_depth != 1) { return; }  # ignore non-toplevel

  my ($mnum) = $path->get_indices;
  my $old_minfo = $self->{'mlist'}->[$mnum];
  my $old_model = $old_minfo && $old_minfo->{'model'};
  my $old_has_child = $old_minfo && $old_minfo->{'has_child'};
  $old_minfo = undef;

  _update_models ($self);

  my $new_minfo = $self->{'mlist'}->[$mnum];
  my $new_model = $new_minfo->{'model'};

  my $iterobj = _top_index_to_iterobj ($self, $mnum);
  $self->row_changed ($path, $iterobj);

  if (! defined $old_has_child ||
      $old_has_child != $new_minfo->{'has_child'}) {
    $self->row_has_child_toggled ($path, $iterobj);
  }

  if (($old_model||0) != ($new_model||0)) {
    if (DEBUG) { print "  different model at $mnum: old ",
                   $old_model||'undef', " new ",$new_model||'undef',"\n";}

    my $old_len = $old_model ? $old_model->iter_n_children(undef) : 0;
    my $new_len = $new_model ? $new_model->iter_n_children(undef) : 0;

    my $changed_len = min ($old_len, $new_len);
    if (DEBUG) { print "  changed_len $changed_len\n"; }
    foreach my $i (0 .. $changed_len - 1) {
      $path = Gtk2::TreePath->new_from_indices ($mnum, $i);
      $iterobj = _sub_index_to_iterobj ($self, $new_minfo, $i);
      $self->row_changed ($path, $iterobj);
    }

    if ($old_len > $changed_len) {
      if (DEBUG) { print "  deleted to $old_len\n"; }
      $path = Gtk2::TreePath->new_from_indices ($mnum, $changed_len);
      foreach ($changed_len .. $old_len - 1) {
        $self->row_deleted ($path);
      }

lib/App/Chart/Gtk2/Ex/ListOfListsModel.pm view on Meta::CPAN

#
sub _do_sublist_row_deleted {
  my ($model, $subpath, $minfo) = @_;
  my $self = $minfo->{'self'} || return;

  if (DEBUG) { print "ListOfListsModel submodel row_deleted handler\n";}
  if ($subpath->get_depth != 1) { return; }  # ignore non-toplevel

  my $mnum = $minfo->{'mnum'};
  my $path = $subpath->copy;
  $path->prepend_index ($mnum);
  $self->row_deleted ($path);

  if ($minfo->{'has_child'} && $model->iter_n_children(undef) == 0) {
    # newly become no-children
    $minfo->{'has_child'} = 0;
    $path->up;
    my $iterobj = _top_index_to_iterobj ($self, $mnum);
    $self->row_has_child_toggled ($path, $iterobj);
  }
}

# 'rows-reordered' on sub-list
#
sub _do_sublist_rows_reordered {
  my ($model, $subpath, $subiter, $aref, $minfo) = @_;
  my $self = $minfo->{'self'} || return;

  if (DEBUG) { print "ListOfListsModel submodel rows_reordered handler\n";}
  if ($subpath->get_depth != 0) { return; } # ignore non-toplevel

  my $mnum = $minfo->{'mnum'};
  my $path = Gtk2::TreePath->new_from_indices ($mnum);
  my $iterobj = _top_index_to_iterobj ($self, $mnum);
  $self->rows_reordered ($path, $iterobj, @$aref);
}


#------------------------------------------------------------------------------
# Gtk2::TreeStore compatible methods

# gtk_tree_store_append
# gtk_tree_store_prepend
sub append {
  push @_, 'append';
  goto _Xpend;
}
sub prepend {
  push @_, 'prepend';
  goto _Xpend;
}
sub _Xpend {
  my ($self, $parent_iterobj, $method) = @_;
  my ($model, $minfo, $subiter);
  if (! defined $parent_iterobj) {
    # append to toplevel
    $model = $self->{'list_model'};
    $subiter = $model->$method;
  } else {
    my $index;
    ($index, $minfo) = _iterobj_validate ($parent_iterobj);
    if ($minfo) { croak 'cannot append under sub-row'; }
    # append to submodel, ie. under a toplevel row
    $minfo = $self->{'mlist'}->[$index] || croak 'no such row (bad iter)';
    $model = $minfo->{'model'};
    $subiter = $model->$method;
  }
  if (! $subiter) { return undef; }
  my ($index) = $model->get_path($subiter)->get_indices;
  return Gtk2::TreeIter->new_from_arrayref ([ $self->{'stamp'}, $index, $minfo, undef]);
}

# gtk_tree_store_is_ancestor
sub is_ancestor {
  my ($self, $parent_iterobj, $child_iterobj) = @_;
  my ($parent_index, $parent_minfo) = _iterobj_validate ($parent_iterobj);
  if ($parent_minfo) { return 0; }  # a submodel row
  my ($child_index, $child_minfo) = _iterobj_validate ($child_iterobj);
  return defined $child_minfo;  # only if a submodel row
}

# gtk_tree_store_iter_depth
sub iter_depth {
  my ($self, $iterobj) = @_;
  my ($index, $minfo) = _iterobj_validate ($iterobj);
  return $minfo ? 2 : 1;
}

# gtk_tree_store_clear
sub clear {
  my ($self) = @_;
  my $list_model = $self->{'list_model'} || return;
  $list_model->clear;
}

# gtk_tree_store_iter_is_valid
# this is not quite right
# if $iter->[2] is bogus it probably causes a segv when treated as an RV
sub iter_is_valid {
  my ($self, $iterobj) = @_;
  my $iter = eval { $iterobj->to_arrayref($self->{'stamp'}) };
  my $index = $iter->[1];
  my $minfo = $iter->[2];
  if (defined $minfo) {
    return List::Util::first {$_ == $minfo} @{$self->{'mlist'}}
      && $index < $minfo->{'model'}->iter_n_children(undef);
  } else {
    return $index < scalar @{$self->{'mlist'}};
  }
}

sub remove {
  my ($self, $iterobj) = @_;
  my ($index, $minfo) = _iterobj_validate ($iterobj);
  my $model = $minfo ? $minfo->{'model'} : $self->{'list_model'};
  my $subiter = $model->iter_nth_child (undef, $index)
    || croak 'no such row (bad iter)';
  if ($model->remove ($subiter)) {
    # more rows
    $iterobj->set([$self->{'stamp'}, $index+1, $minfo, undef]);
    return 1;
  } else {
    $iterobj->set([0,0,undef,undef]); # zap
    return 0;
  }
}

# gtk_tree_store_reorder
# Gtk2::TreeStore reorder() taking multiple args
sub reorder {
  my ($self, $iterobj, @order) = @_;
  if ($iterobj) {
    my ($index, $minfo) = _iterobj_validate ($iterobj);
    if ($minfo) {
      croak 'nothing under sub-row';
    }
    $minfo = $self->{'mlist'}->[$index] || croak 'iter out of range';
    my $model = $minfo->{'model'} || croak 'no submodel';
    $model->reorder (@order);

  } else {
    # toplevel
    $self->{'list_model'}->reorder (@order);
  }
}


#------------------------------------------------------------------------------
# other methods

sub path_for_model {
  my ($self, $model) = @_;
  my $mlist = $self->{'mlist'};
  foreach my $minfo (@$mlist) {
    my $this_model = $minfo->{'model'} || next;
    if ($model == $this_model) {
      return Gtk2::TreePath->new_from_indices ($minfo->{'mnum'});
    }
  }
  return undef;
}


#------------------------------------------------------------------------------
# drag source

# gtk_tree_drag_source_row_draggable ($self, $path)
#
sub ROW_DRAGGABLE {
  unshift @_, 'row_draggable';
  goto &_drag_source;
}

# gtk_tree_drag_source_drag_data_delete ($self, $path)
#
sub DRAG_DATA_DELETE {
  unshift @_, 'drag_data_delete';
  goto &_drag_source;
}

# gtk_tree_drag_source_drag_data_get
#
sub DRAG_DATA_GET {
  my ($self, $path, $sel) = @_;
  unshift @_, 'drag_data_get';  # needing Gtk2 1.200
  goto &_drag_source;
}

sub _drag_source {
  my ($method, $self, $path, @sel) = @_;
  if (DEBUG) { print "ListOfLists \U$method\E path=",$path->to_string,"\n"; }

  my ($model, $subpath) = _drag_path ($self, $path)

( run in 1.025 second using v1.01-cache-2.11-cpan-39bf76dae61 )