Hi Andy,
guile-gnome users,
Launching the following little application example and clicking the 'Start'
button
systematically provoke a segmentation fault on guile-gnome-2 [and guile-gnome-0]
Does it crashes for you [any guile-gnome user willing to try?] too?
Thanks,
David
ps: while building this small example, I thought it was due to the calls
...
(gtku/status-pop statusbar "")
(gtku/status-push statusbar (get-value model iter 0) "")
...
in my (connect selection 'changed ...) code, but then I commented and it
still crashed.
;; --
Le Thu, 01 Jul 2010 11:58:04 +0100,
Andy Wingo <wi...@pobox.com> a écrit :
> On Tue 29 Jun 2010 22:33, David Pirotte <da...@altosw.be> writes:
>
> > I'll try to produce a better backtrace [some .deb package have no -dbg
> > corresponding package and the -dev do not always include debugging symbols]
> >
> > But in order to help me helping developpers to get rid og this bug [which
> > did
> > not desappear with the guile-gnome0 -> guile-gnome2 'porting' [in progress
> > but
> > some bits working already], I am sending what i could come up with so far.
>
> Thanks for the report. Unfortunately the backtrace is not
> sufficient. Something is being freed with g_free which should be freed
> via a specific deallocator. Can you check to see that the following
> patches are applied to the debian package:
>
> 0ca1de9d89ed7b2899e49f273f27f810540a6508
> 3d11c93b290992b2c4d9eeef57c2a7a54f808783
>
> Thanks,
> Andy
#! /bin/sh
# -*- scheme -*-
hn=`hostname`
if [[ "$hn" == "tabu" ]]
then exec guile-gnome-0 -s $0 "$@"
else exec guile-gnome-2 -s $0 "$@"
fi
!#
;; guile-gnome
;; Copyright (C) 2003,2004 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA g...@gnu.org
(read-set! keywords 'prefix)
(use-modules (ice-9 receive)
(oop goops)
(gnome gobject)
(gnome gtk)
(gnome gtk gdk-event))
(define *model* #f)
(define *selection* #f)
(define (pack-tv-column tv column renderer pos)
(pack-start column renderer #t)
(add-attribute column renderer "text" pos)
(append-column tv column))
(define (add-columns treeview)
(let* ((renderer1 (make <gtk-cell-renderer-text>))
(column1 (make <gtk-tree-view-column>
:title "Column 1"
:sizing 'fixed
:fixed-width 65
;:clickable #f
;:resizable #f
;:reorderable #f
:alignment .5
))
(renderer2 (make <gtk-cell-renderer-text>))
(column2 (make <gtk-tree-view-column>
:title "Column 2"
:sizing 'fixed
:fixed-width 65
;:clickable #f
;:resizable #f
;:reorderable #f
:alignment .5
))
(renderer3 (make <gtk-cell-renderer-text>))
(column3 (make <gtk-tree-view-column>
:title "Column 3"
:expand #t
:alignment .5
))
;; ROW BACKGROUND COLOUR
(renderer4 (make <gtk-cell-renderer-text>
:xalign 1))
(column4 (make <gtk-tree-view-column>
:visible #f
))
;; ROW FOREGROUND COLOUR
(renderer5 (make <gtk-cell-renderer-text>
:xalign 1))
(column5 (make <gtk-tree-view-column>
:visible #f
)))
(pack-tv-column treeview column1 renderer1 0)
(pack-tv-column treeview column2 renderer2 1)
(pack-tv-column treeview column3 renderer3 2)
(pack-tv-column treeview column4 renderer4 3)
(pack-tv-column treeview column5 renderer5 4)
;; background colour
(add-attribute column1 renderer1 "cell-background" 3)
(add-attribute column2 renderer2 "cell-background" 3)
(add-attribute column3 renderer3 "cell-background" 3)
;; foreground colour
(add-attribute column1 renderer1 "foreground" 4)
(add-attribute column2 renderer2 "foreground" 4)
(add-attribute column3 renderer3 "foreground" 4)
(set-search-column treeview 2)
))
(define (ocs/add-model treeview)
(let* ((column-types (list <gchararray>
<gchararray>
<gchararray>
<gchararray>
<gchararray>))
(model (gtk-list-store-new column-types)))
(set-model treeview model)
(values model
(get-selection treeview))
))
(define (setup-treeview treeview)
(add-columns treeview)
(receive (model selection)
(ocs/add-model treeview)
(set-mode selection 'single)
(values model selection)))
(define (populate-model model)
(for-each (lambda (row)
(let ((iter (gtk-list-store-append model)))
(set-value model iter 0 (car row))
(set-value model iter 1 (cadr row))
(set-value model iter 2 (caddr row))))
'(("r1c1" "r1c2" "r1c3")
("r2c1" "r2c2" "r2c3")
("r3c1" "r3c2" "r3c3"))
))
(define (make-simple-popup-menu entries)
(let ((menu (make <gtk-menu>)))
(for-each (lambda (entry)
(if (pair? entry)
(let* ((label (car entry))
(callback (cdr entry))
(menu-item (gtk-menu-item-new-with-label label)))
(connect menu-item
'activate
(lambda (widget)
(callback)))
(gtk-menu-shell-append menu menu-item)
(show menu-item))
(let ((menu-item (gtk-separator-menu-item-new)))
(gtk-menu-shell-append menu menu-item)
(show menu-item))))
entries)
menu))
(define (gtku/status-push status-bar message source)
(let ((context-id (gtk-statusbar-get-context-id status-bar source)))
(gtk-statusbar-push status-bar context-id message)))
(define (gtku/status-pop status-bar source)
(let ((context-id (gtk-statusbar-get-context-id status-bar source)))
(gtk-statusbar-pop status-bar context-id)))
(define (make-popup-menu)
(make-simple-popup-menu `(("popup option 1" . ,(lambda () (display "popup option 1\n")))
("popup option 2" . ,(lambda () (display "popup option 2\n")))
separator
("popup option 3" . ,(lambda () (display "popup option 3\n"))))
))
(define (test-suite-1 treeview model selection popup-menu)
(let ((i 0)
(nb-rows -1)
(bgcolours '("Black" "grey20" "grey40"))
(fgcolours '("white" "wheat" "royalblue")))
(while (< i 1000)
(let* ((sibling (get-iter model 2))
;; (iter (gtk-list-store-append model))
(iter (insert-after model sibling))
)
(set-value model iter 0 (symbol->string (gensym "gs-")))
(set-value model iter 1 (symbol->string (gensym "gs-")))
(set-value model iter 2 (symbol->string (gensym "gs-")))
(set-value model iter 3 (list-ref bgcolours (modulo i 3)))
(set-value model iter 4 (list-ref fgcolours (modulo i 3)))
)
(select-path selection (list (modulo i 100)))
(set! i (1+ i)))
(select-path selection (list 0))
(set! i 0)
(while (< i 500)
(let ((iter (get-iter model (list i))))
(set-value model iter 3 "grey20")
(set-value model iter 4 "Royalnavy1")
(remove model iter))
(set! i (1+ i)))
(set! nb-rows (gtk-tree-model-iter-n-children model #f))
;; (gtk-menu-popup popup-menu #f #f #f 3 0)
(select-path selection (list 2))
(set! i 0)
(while (< i nb-rows)
(gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3)
(set! i (1+ i)))
))
(define (test-suite-2 treeview model selection first next)
(let ((nb-rows (gtk-tree-model-iter-n-children model #f))
(i 0))
(emit first 'clicked)
(while (< i nb-rows)
;; (select-path selection (list i))
;; (gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3)
;; (usleep 500)
(emit next 'clicked)
(set! i (1+ i)))
))
(define (start-test treeview model selection popup-menu first next)
(let ((i 0))
(gtk-list-store-clear model)
(test-suite-1 treeview model selection popup-menu)
(while (< i 10)
(test-suite-2 treeview model selection first next)
(set! i (1+ i))
)))
(define (animate)
(let* ((window (make <gtk-window>
:type 'toplevel
:title "Get path at pos test"
))
(vbox (make <gtk-vbox>
:homogeneous #f
:spacing 2))
(hbox (make <gtk-hbox>
:homogeneous #f
:spacing 2))
(scrollw (make <gtk-scrolled-window>
:hscrollbar-policy 'never
:vscrollbar-policy 'automatic))
(treeview (make <gtk-tree-view>))
(firstrow (make <gtk-button>
:label "first row")) ;; (gtk-stock-id 'close)
(nextrow (make <gtk-button>
:label "next row")) ;; (gtk-stock-id 'close)
(test-1 (make <gtk-button>
:label "Test suite"))
(test-2 (make <gtk-button>
:label "Start ..."))
(statusbar (make <gtk-statusbar>))
(popup-menu (make-popup-menu)))
(set-default-size window 400 150)
(receive (model selection)
(setup-treeview treeview)
(populate-model model)
(add window vbox)
(add scrollw treeview)
(pack-start vbox scrollw #t #t 0)
(pack-start vbox hbox #f #f 0)
(pack-start hbox firstrow #f #f 0)
(pack-start hbox nextrow #f #f 0)
(pack-start hbox test-1 #f #f 0)
(pack-start hbox test-2 #t #t 0)
(pack-start vbox statusbar #f #f 0)
(connect window
'delete-event
(lambda (widget event)
(destroy widget)
(gtk-main-quit)
#f))
(connect selection
'changed
(lambda (selection)
(receive (model iter)
(get-selected selection)
(if iter
(let* ((path (get-path model iter))
(row (car path)))
;(gtku/status-pop statusbar "")
;(gtku/status-push statusbar (get-value model iter 0) "")
#t
)))
#f))
(connect treeview
'button-press-event
(lambda (w ev)
(case (gdk-event:type ev)
((button-press)
(let* ((button (gdk-event-button:button ev))
(time (gdk-event-button:time ev))
(x-pos (inexact->exact (gdk-event-button:x ev)))
(y-pos (inexact->exact (gdk-event-button:y ev)))
(path-values;; (get-path-at-pos w x-pos y-pos)
(values (list 1) #t 10 10)
))
(case button
((3)
(receive (indices bool x y)
path-values
(let* ((row (car indices))
(iter (get-iter model row)))
(gtk-menu-popup popup-menu
#f ;; parent-menu-shell or #f
#f ;; parent-menu-item or #f
#f ;; user supplied func to position the menu or #f
;; #f - no more user supplied data to pass to func
button
time
)))))))
((2button-press)
(simple-format #t "ignoring 2button-press events...~%"))
((3button-press)
(simple-format #t "ignoring 3button-press events...~%"))
)
#f
))
(connect firstrow
'clicked
(lambda (but)
(select-path selection (list 0))
(gtk-tree-view-scroll-to-cell treeview (list 0) #f #t 0.3)))
(connect nextrow
'clicked
(lambda (but)
(receive (model iter)
(get-selected selection)
(if iter
(let* ((path (get-path model iter))
(row (car path))
(new-path (list (1+ row))))
(select-path selection new-path)
(gtk-tree-view-scroll-to-cell treeview new-path #f #t 0.3))))
))
(connect test-1
'clicked
(lambda (but)
(start-test treeview model selection popup-menu firstrow nextrow)))
(connect test-2
'clicked
(lambda (but)
(let ((i 0))
(while (< i 10)
(emit test-1 'clicked)))))
)
(show-all window)
(gtk-main)))
(animate)
