← Back to branch summary

~ubuntu-branches/ubuntu/lucid/sawfish/lucid-updates

« back to all changes in this revision

Viewing changes to lisp/sawfish/gtk/widget-test.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2002-01-20 17:42:28 UTC
  • Revision ID: james.westby@ubuntu.com-20020120174228-4q1ydztbkvfq1ht2
Tags: upstream-1.0.1.20020116
Import upstream version 1.0.1.20020116

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/gtk/widget-test.jl
 
1
#| nokogiri-widget-test.jl -- test harness for widgets
 
2
 
 
3
   $Id: widget-test.jl,v 1.6 2000/09/11 07:44:42 john Exp $
 
4
 
 
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
 
6
 
 
7
   This file is part of sawfish.
 
8
 
 
9
   sawfish is free software; you can redistribute it and/or modify it
 
10
   under the terms of the GNU General Public License as published by
 
11
   the Free Software Foundation; either version 2, or (at your option)
 
12
   any later version.
 
13
 
 
14
   sawfish is distributed in the hope that it will be useful, but
 
15
   WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
17
   GNU General Public License for more details.
 
18
 
 
19
   You should have received a copy of the GNU General Public License
 
20
   along with sawfish; see the file COPYING.  If not, write to
 
21
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
22
|#
 
23
 
 
24
(define-structure sawfish.gtk.widget-test
 
25
 
 
26
    (export test-widget)
 
27
 
 
28
    (open rep
 
29
          gui.gtk
 
30
          rep.system
 
31
          sawfish.gtk.widget)
 
32
 
 
33
  (define (test-widget spec #!optional initial-value)
 
34
    (let (widget)
 
35
      (setq widget (make-widget spec (lambda ()
 
36
                                       (when widget
 
37
                                         (format standard-output
 
38
                                                 "changed: %s\n"
 
39
                                                 (widget-ref widget))))))
 
40
      (when initial-value
 
41
        (or (widget-valid-p widget initial-value)
 
42
            (error "Value is not suitable for widget: %s" initial-value))
 
43
        (widget-set widget initial-value))
 
44
      (let ((window (gtk-window-new 'toplevel)))
 
45
        (gtk-container-add window (widget-gtk-widget widget))
 
46
        (gtk-signal-connect window "delete_event"
 
47
                            (lambda () (throw 'done t)))
 
48
        (gtk-widget-show-all window)
 
49
        (unwind-protect
 
50
            (catch 'done
 
51
              (recursive-edit))
 
52
          (gtk-widget-destroy window)
 
53
          (gdk-flush))))))