/[cells]/cells-gtk/dialogs.lisp
ViewVC logotype

Contents of /cells-gtk/dialogs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Wed Jan 30 21:13:44 2008 UTC (6 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +19 -16 lines
fixed submenus
1 #|
2
3 Cells Gtk
4
5 Copyright (c) 2004 by Vasilis Margioulas <vasilism@sch.gr>
6
7 You have the right to distribute and use this software as governed by
8 the terms of the Lisp Lesser GNU Public License (LLGPL):
9
10 (http://opensource.franz.com/preamble.html)
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :cgtk)
20
21
22 (def-widget message-dialog (window)
23 ((message :accessor message :initarg :message :initform nil)
24 (message-type :accessor message-type :initarg :message-type :initform :info)
25 (buttons-type :accessor buttons-type :initarg :buttons-type :initform (c? (if (eql (message-type self) :question)
26 :yes-no
27 :close)))
28 (content-area :owning t :accessor content-area :initarg :content-area :initform nil))
29 (markup)
30 ()
31 :position :mouse
32 :new-args (c_1 (list +c-null+
33 2
34 (ecase (message-type self)
35 (:info 0)
36 (:warning 1)
37 (:question 2)
38 (:error 3))
39 (ecase (buttons-type self)
40 (:none 0)
41 (:ok 1)
42 (:close 2)
43 (:cancel 3)
44 (:yes-no 4)
45 (:ok-cancel 5))
46 (message self))))
47
48 (defmethod md-awaken :after ((self message-dialog))
49 (print 'md-awaken-after)
50 (let ((response (gtk-dialog-run (id self))))
51 (setf (value self)
52 (case response
53 (-5 :ok)
54 (-6 :cancel)
55 (-7 :close)
56 (-8 :yes)
57 (-9 :no))))
58
59 (with-slots (content-area) self
60 (when content-area
61 (setf (value self) (value content-area))
62 (print (value content-area))
63 (gtk-object-forget (id content-area) content-area)))
64 (gtk-widget-destroy (id self))
65 (gtk-object-forget (id self) self)
66 (print 'done))
67
68 (defun show-message (text &rest inits)
69 (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits))))
70 (value message-widget)))
71
72 (def-object file-filter ()
73 ((mime-types :accessor mime-types :initarg :mime-types :initform nil)
74 (patterns :accessor patterns :initarg :patterns :initform nil))
75 (name)
76 ())
77
78 (defobserver content-area ((self message-dialog))
79 (when new-value
80 (let ((vbox (gtk-adds-dialog-vbox (id self))))
81 (gtk-box-pack-start vbox (id new-value) nil nil 5))))
82
83 (defobserver mime-types ((self file-filter))
84 (dolist (mime-type new-value)
85 (gtk-file-filter-add-mime-type (id self) mime-type)))
86
87 (defobserver patterns ((self file-filter))
88 (dolist (pattern new-value)
89 (gtk-file-filter-add-pattern (id self) pattern)))
90
91 (def-object file-chooser ()
92 ((action :accessor action :initarg :action :initform nil)
93 (action-id :accessor action-id
94 :initform (c? (ecase (action self)
95 (:open 0)
96 (:save 1)
97 (:select-folder 2)
98 (:create-folder 3))))
99 (filters :accessor filters :initarg :filters :initform nil)
100 (filters-ids :accessor filters-ids
101 :initform (c? (loop for filter in (filters self) collect
102 (id (make-be 'file-filter :name (first filter) :patterns (rest filter)))))))
103 (local-only select-multiple current-name filename
104 current-folder uri current-folder-uri use-preview-label filter)
105 (selection-changed)
106 :on-selection-changed (callback (widget signal data)
107 (if (select-multiple self)
108 (setf (value self) (gtk-file-chooser-get-filenames-strs (id self)))
109 (setf (value self) (gtk-file-chooser-get-filename (id self))))))
110
111 (defobserver filters-ids ((self file-chooser))
112 (dolist (filter-id new-value)
113 (gtk-file-chooser-add-filter (id self) filter-id)))
114
115 (defobserver action ((self file-chooser))
116 (when new-value
117 (gtk-file-chooser-set-action (id self) (action-id self))))
118
119 (def-widget file-chooser-widget (file-chooser vbox)
120 ()
121 ()
122 ()
123 :new-args (c_1 (list (action-id self))))
124
125 (def-widget file-chooser-dialog (file-chooser window)
126 ()
127 ()
128 ()
129 :on-selection-changed nil
130 :position :mouse
131 :new-args (c_1 (list (title self) +c-null+ (action-id self)
132 "gtk-cancel" -6 ;;response-cancel
133 (format nil "gtk-~a"
134 (string-downcase
135 (symbol-name
136 (if (eql (action self) :select-folder)
137 :open
138 (if (eql (action self) :create-folder)
139 :apply
140 (action self))))))
141 -5 ;;response-ok
142 +c-null+)))
143
144 (defmethod md-awaken :after ((self file-chooser-dialog))
145 (let ((response (gtk-dialog-run (id self))))
146 (when (eql response -5)
147 (if (select-multiple self)
148 (setf (value self) (gtk-file-chooser-get-filenames-strs (id self)))
149 (setf (value self) (gtk-file-chooser-get-filename (id self)))))
150 (trc "destroying file-chooser-dialog" (id self) self)
151 (break "ok?")
152 (gtk-widget-destroy (id self))
153 (gtk-object-forget (id self) self)))
154
155 (defun file-chooser (&rest inits)
156 (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits))))
157 (value dialog)))
158

  ViewVC Help
Powered by ViewVC 1.1.5