File: error-dialog.scm

package info (click to toggle)
gauche-gtk 0.4.1-2
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 2,520 kB
  • ctags: 3,230
  • sloc: ansic: 6,655; lisp: 4,159; sh: 2,707; makefile: 344
file content (65 lines) | stat: -rw-r--r-- 2,330 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
;;;
;;; gtk/error-dialog.scm - reports error via GUI dialog
;;;
;;;  Copyright(C) 2002 by Shiro Kawai (shiro@acm.org)
;;;
;;;  Permission to use, copy, modify, distribute this software and
;;;  accompanying documentation for any purpose is hereby granted,
;;;  provided that existing copyright notices are retained in all
;;;  copies and that this notice is included verbatim in all
;;;  distributions.
;;;  This software is provided as is, without express or implied
;;;  warranty.  In no circumstances the author(s) shall be liable
;;;  for any damages arising out of the use of this software.
;;;
;;;  $Id: error-dialog.scm,v 1.2 2002/11/21 01:03:59 shirok Exp $
;;;

;; this file is to be autoloaded.

;; makes an error to be reported using gtk dialog.

(define-module gtk.error-dialog
  (use gauche.mop.singleton)
  (use gauche.threads)
  (use gtk)
  (export gtk-scheme-enable-error-dialog <error-dialog>))
(select-module gtk.error-dialog)

(define-class <error-dialog> (<singleton-mixin>)
  ((widget)
   (label)
   (parent :init-keyword :parent :init-value #f)
   (flags  :init-keyword :flags  :init-value 0)
   ))

(define-method initialize ((self <error-dialog>) initargs)
  (next-method)
  (let* ((dialog (gtk-dialog-new-with-buttons "Error"
                                              (ref self 'parent)
                                              (ref self 'flags)
                                              GTK_STOCK_OK
                                              GTK_RESPONSE_ACCEPT))
         (vbox   (ref dialog 'vbox))
         (label  (gtk-label-new "")))
    (g-signal-connect dialog "response"
                      (lambda _ (gtk-widget-hide-all dialog)))
    (gtk-box-pack-start vbox label  #t #t 10)
    (slot-set! self 'widget dialog)
    (slot-set! self 'label label)
    ))

(define (report-error exc)
  (let ((self (instance-of <error-dialog>))
        (mesg (if (is-a? exc <error>)
                  #`"*** ERROR: ,(ref exc 'message)"
                  (x->string exc)))
        )
    (gtk-label-set-text (ref self 'label) mesg)
    (gtk-widget-show-all (ref self 'widget))))

(define (gtk-scheme-enable-error-dialog . maybe-parent)
  (make <error-dialog> :parent (get-optional maybe-parent #f))
  (vm-set-default-exception-handler (current-thread) report-error))

(provide "gtk/error-dialog")