chiark / gitweb /
Added new function INIT-CHILD-SLOTS
[clg] / gtk / gtk.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
8ab0db90 2;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
560af5c5 3;;
112ac1d3 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
560af5c5 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
560af5c5 14;;
112ac1d3 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
560af5c5 22
d29387c6 23;; $Id: gtk.lisp,v 1.76 2007-06-25 10:36:43 espen Exp $
560af5c5 24
25
26(in-package "GTK")
27
28;;; Gtk version
29
6bb23851 30(defbinding check-version () (copy-of string)
560af5c5 31 (required-major unsigned-int)
32 (required-minor unsigned-int)
33 (required-micro unsigned-int))
34
bbaeff4b 35(defbinding query-version () nil
560af5c5 36 (major unsigned-int :out)
37 (minor unsigned-int :out)
38 (micro unsigned-int :out))
39
40(defun gtk-version ()
41 (multiple-value-bind (major minor micro)
42 (query-version)
43 (if (zerop micro)
44 (format nil "Gtk+ v~A.~A" major minor)
45 (format nil "Gtk+ v~A.~A.~A" major minor micro))))
46
c1c0746b 47(defun clg-version ()
904a03a9 48 "clg 0.93")
560af5c5 49
50
e3cdfeea 51;;;; Initalization and display handling
9adccb27 52
050f6c9f 53(defparameter *event-poll-interval* 10000) ; in microseconds
54
55
a5522de5 56(defbinding (gtk-init "gtk_parse_args") () boolean
9adccb27 57 "Initializes the library without opening the display."
58 (nil null)
59 (nil null))
60
050f6c9f 61(defun clg-init (&optional display multi-threading-p)
62 "Initializes the system and starts event handling."
9adccb27 63 (unless (gdk:display-get-default)
76fe8daf 64 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
65 (progn
66 #+sbcl(sb-int:set-floating-point-modes :traps nil)
67 #+cmu(ext:set-floating-point-modes :traps nil))
68
050f6c9f 69 (gdk:gdk-init)
70 (unless (gtk-init)
71 (error "Initialization of GTK+ failed."))
72
73 (if (not multi-threading-p)
74 (%init-async-event-handling display)
75 #+sb-thread(%init-multi-threaded-event-handling display)
76 #-sb-thread(error "Multi threading not supported on this platform")))
f5c99598 77 (gdk:ensure-display display t))
050f6c9f 78
8ab0db90 79(defun clg-init-with-threading (&optional display)
050f6c9f 80 (clg-init display t))
81
82
83#?(sbcl>= 1 0 6)
84;; A very minimal implementation of CLISP's socket-status
85(defun socket-status (socket seconds microseconds)
86 (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set)))
87 (let ((fd (sb-sys:fd-stream-fd (car socket))))
88 (sb-unix:fd-zero read-fds)
89 (sb-unix:fd-set fd read-fds)
90
24a63041 91 (let ((num-fds-changed
92 (sb-unix:unix-fast-select
93 (1+ fd) (sb-alien:addr read-fds) nil nil
94 seconds microseconds)))
95 (unless (or (not num-fds-changed) (zerop num-fds-changed))
96 (if (peek-char nil (car socket) nil)
97 :input
98 :eof))))))
050f6c9f 99
100(defun %init-async-event-handling (display)
101 (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler
102 #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil))
103 (when (and
104 (find-package "SWANK")
105 (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style)))
106 (error "When running clg in Slime, the communication style ~A must be used in combination with asynchronous event handling on this platform. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information." style)))
107
108 #?(or (featurep :cmu) (sbcl< 1 0 6))
109 (progn
110 (signal-connect (gdk:display-manager) 'display-opened
111 #'(lambda (display)
112 (let ((fd (gdk:display-connection-number display)))
113 (unless (< fd 0)
114 (let ((handler (add-fd-handler
115 (gdk:display-connection-number display)
116 :input #'main-iterate-all)))
117 (signal-connect display 'closed
118 #'(lambda (is-error-p)
119 (declare (ignore is-error-p))
120 (remove-fd-handler handler))))))))
121 (setq *periodic-polling-function* #'main-iterate-all)
122 (setq *max-event-to-sec* 0)
123 (setq *max-event-to-usec* *event-poll-interval*))
124
125 #+(and clisp readline)
126 ;; Readline will call the event hook at most ten times per second
127 (setf readline:event-hook #'main-iterate-all)
128
129 #?-(or (featurep :cmu) (sbcl< 1 0 6))
130 ;; When running in Slime we need to hook into the Swank server
131 ;; to handle events asynchronously.
132 (if (find-package "SWANK")
133 (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")))
134 (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))))
135 (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))
136 #'(lambda ()
137 (loop
138 (case (socket-status (cons stream :input) 0 *event-poll-interval*)
139 ((:input :eof) (return (funcall read-from-emacs)))
140 (otherwise (main-iterate-all)))))))
141 #-(and clisp readline)
142 (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started."))
143
144 (gdk:display-open display))
145
146#+sb-thread
147(progn
148 (defvar *main-thread* nil)
149
150 ;; Hopefully, when threading support is added to the Win32 port of
151 ;; SBCL in the future, this will work just out of the box.
152 #+win32
153 (let ((done (sb-thread:make-waitqueue))
154 (functions ())
155 (results ()))
156
157 ;; In Win32 all GDK calls have to be made from the main loop
158 ;; thread, so we add a timeout function which will poll for code and
159 ;; execute it.
160
161 (defun funcall-in-main (function)
162 (if (or
163 (not *main-thread*)
164 (eq sb-thread:*current-thread* *main-thread*))
165 (funcall function)
166 (gdk:with-global-lock
167 (push function functions)
168 (sb-thread:condition-wait done gdk:*global-lock*)
169 (pop results))))
170
171 ;; Will lock REPL on error, need to be fixed!
172 (defun %funcall-in-main-poll ()
173 (when functions
174 (loop
175 for n from 0
176 while functions
177 do (push (funcall (pop functions)) results)
178 finally (sb-thread:condition-notify done n)))
179 t))
180
181 (defmacro within-main-loop (&body body)
182 #-win32 `(gdk:with-global-lock ,@body)
183 #+win32 `(funcall-in-main #'(lambda () ,@body)))
184
185 (defun %init-multi-threaded-event-handling (display)
186 (when (and
187 (find-package "SWANK")
188 (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)))
189 (error "When running clg in Slime, the communication style :spawn must be used in combination with multi threaded event handling. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
190 (let ((main-running (sb-thread:make-waitqueue)))
191 (gdk:with-global-lock
192 (setf *main-thread*
193 (sb-thread:make-thread
194 #'(lambda ()
195 (gdk:threads-init)
196 (gdk:with-global-lock
197 (gdk:display-open display)
198 #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000)
199 #'%funcall-in-main-poll)
200 (sb-thread:condition-notify main-running)
201 (main)))
202 :name "gtk event loop"))
203 (sb-thread:condition-wait main-running gdk:*global-lock*)))
204
205 ;; We need to hook into the Swank server to protect calls to GDK properly.
206 ;; This will *only* protect code entered directly in the REPL.
207 (when (find-package "SWANK")
208 (push #'(lambda (form)
209 (within-main-loop (eval form)))
210 swank::*slime-repl-eval-hooks*))))
211
212#-sb-thread
213(defmacro within-main-loop (&body body)
214 `(progn ,@body))
76fe8daf 215
9adccb27 216
18b84c80 217
db85b082 218;;; Generic functions
219
220(defgeneric add-to-radio-group (item1 item2))
221(defgeneric activate-radio-widget (item))
222(defgeneric (setf tool-item-tip-text) (tip-text tool-item))
223(defgeneric (setf tool-item-tip-private) (tip-private tool-item))
224
225
9adccb27 226
667a112b 227;;; Misc
228
229(defbinding grab-add () nil
230 (widget widget))
231
7abdba43 232(defbinding grab-get-current () widget)
667a112b 233
234(defbinding grab-remove () nil
235 (widget widget))
236
c1c0746b 237(defbinding get-default-language () (copy-of pango:language))
238
667a112b 239
647c99e5 240;;; About dialog
241
8ab0db90 242#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
647c99e5 243(progn
56ccd5b7 244 (define-callback-marshal %about-dialog-activate-link-callback nil
245 (about-dialog (link string)))
647c99e5 246
247 (defbinding about-dialog-set-email-hook (function) nil
56ccd5b7 248 (%about-dialog-activate-link-callback callback)
647c99e5 249 ((register-callback-function function) unsigned-int)
56ccd5b7 250 (user-data-destroy-callback callback))
647c99e5 251
252 (defbinding about-dialog-set-url-hook (function) nil
56ccd5b7 253 (%about-dialog-activate-link-callback callback)
647c99e5 254 ((register-callback-function function) unsigned-int)
56ccd5b7 255 (user-data-destroy-callback callback)))
647c99e5 256
257
0f476ab5 258;;; Acccel group
560af5c5 259
31700e82 260(defbinding %accel-group-connect () nil
261 (accel-group accel-group)
262 (key unsigned-int)
263 (modifiers gdk:modifier-type)
264 (flags accel-flags)
265 (gclosure gclosure))
266
267(defun accel-group-connect (group accelerator function &optional flags)
eacab64f 268 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
31700e82 269 (let ((gclosure (make-callback-closure function)))
270 (%accel-group-connect group key modifiers flags gclosure)
271 gclosure)))
272
273(defbinding accel-group-connect-by-path (group path function) nil
274 (group accel-group)
275 (path string)
8ab0db90 276 ((make-callback-closure function) gclosure :in/return))
31700e82 277
278(defbinding %accel-group-disconnect (group gclosure) boolean
279 (group accel-group)
280 (gclosure gclosure))
281
282(defbinding %accel-group-disconnect-key () boolean
283 (group accel-group)
284 (key unsigned-int)
285 (modifiers gdk:modifier-type))
286
287(defun accel-group-disconnect (group accelerator)
288 (etypecase accelerator
289 (gclosure (%accel-group-disconnect group accelerator))
290 (string
eacab64f 291 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
31700e82 292 (%accel-group-disconnect-key group key modifiers)))))
293
eacab64f 294(defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
295 (accel-group accel-group)
296 (key unsigned-int)
297 (modifiers gdk:modifier-type)
298 (n int :out))
299
300(defun accel-group-query (accel-group accelerator)
301 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
302 (%accel-group-query accel-group key modifiers)))
303
304(defbinding %accel-group-activate () boolean
305 (accel-group accel-group)
306 (acceleratable gobject)
307 (key unsigned-int)
308 (modifiers gdk:modifier-type))
309
310(defun accel-group-activate (accel-group acceleratable accelerator)
311 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
312 (%accel-group-activate accel-group acceleratable key modifiers)))
313
31700e82 314(defbinding accel-group-lock () nil
315 (accel-group accel-group))
316
317(defbinding accel-group-unlock () nil
318 (accel-group accel-group))
319
eacab64f 320(defbinding accel-group-from-accel-closure () accel-group
321 (closure gclosure))
322
31700e82 323(defbinding %accel-groups-activate () boolean
324 (object gobject)
325 (key unsigned-int)
326 (modifiers gdk:modifier-type))
327
328(defun accel-groups-activate (object accelerator)
eacab64f 329 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
31700e82 330 (%accel-groups-activate object key modifiers)))
331
332(defbinding accel-groups-from-object () (gslist accel-groups)
333 (object gobject))
334
73572c12 335(defbinding accelerator-valid-p (key &optional modifiers) boolean
31700e82 336 (key unsigned-int)
337 (modifiers gdk:modifier-type))
338
339(defbinding %accelerator-parse () nil
340 (accelerator string)
341 (key unsigned-int :out)
342 (modifiers gdk:modifier-type :out))
343
eacab64f 344(defgeneric parse-accelerator (accelerator))
345
346(defmethod parse-accelerator ((accelerator string))
31700e82 347 (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
348 (if (zerop key)
349 (error "Invalid accelerator: ~A" accelerator)
350 (values key modifiers))))
351
eacab64f 352(defmethod parse-accelerator ((accelerator cons))
353 (destructuring-bind (key modifiers) accelerator
354 (values
355 (etypecase key
356 (integer key)
357 (string
358 (or
359 (gdk:keyval-from-name key)
360 (error "Invalid key name: ~A" key)))
361 (character (parse-accelerator key)))
362 modifiers)))
363
364(defmethod parse-accelerator ((key integer))
365 key)
366
367(defmethod parse-accelerator ((key character))
368 (or
369 (gdk:keyval-from-name (string key))
370 (error "Invalid key name: ~A" key)))
371
372
31700e82 373(defbinding accelerator-name () string
374 (key unsigned-int)
375 (modifiers gdk:modifier-type))
376
8ab0db90 377#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
31700e82 378(defbinding accelerator-get-label () string
379 (key unsigned-int)
380 (modifiers gdk:modifier-type))
381
382(defbinding %accelerator-set-default-mod-mask () nil
383 (default-modifiers gdk:modifier-type))
384
385(defun (setf accelerator-default-modifier-mask) (default-modifiers)
386 (%accelerator-set-default-mod-mask default-modifiers))
387
388(defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)
560af5c5 389
1047e159 390
560af5c5 391;;; Acccel label
392
eacab64f 393(defbinding accel-label-get-accel-width () unsigned-int
394 (accel-label accel-label))
395
bbaeff4b 396(defbinding accel-label-refetch () boolean
560af5c5 397 (accel-label accel-label))
398
399
31700e82 400
401;;; Accel map
402
403(defbinding %accel-map-add-entry () nil
404 (path string)
405 (key unsigned-int)
406 (modifiers gdk:modifier-type))
407
408(defun accel-map-add-entry (path accelerator)
eacab64f 409 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
31700e82 410 (%accel-map-add-entry path key modifiers)))
411
eacab64f 412(defbinding %accel-map-lookup-entry () boolean
31700e82 413 (path string)
8ab0db90 414 ((make-instance 'accel-key) accel-key :in/return))
eacab64f 415
416(defun accel-map-lookup-entry (path)
417 (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
418 (when found-p
419 (values
420 (slot-value accel-key 'key)
421 (slot-value accel-key 'modifiers)
422 (slot-value accel-key 'flags)))))
31700e82 423
424(defbinding %accel-map-change-entry () boolean
425 (path string)
426 (key unsigned-int)
427 (modifiers gdk:modifier-type)
428 (replace boolean))
429
430(defun accel-map-change-entry (path accelerator &optional replace)
eacab64f 431 (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
31700e82 432 (%accel-map-change-entry path key modifiers replace)))
433
434(defbinding accel-map-load () nil
435 (filename pathname))
436
437(defbinding accel-map-save () nil
438 (filename pathname))
439
56ccd5b7 440(define-callback-marshal %accel-map-foreach-callback nil
441 ((accel-path string) (key unsigned-int)
442 (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)
eacab64f 443
444(defbinding %accel-map-foreach (callback-id) nil
445 (callback-id unsigned-int)
56ccd5b7 446 (%accel-map-foreach-callback callback))
eacab64f 447
448(defbinding %accel-map-foreach-unfiltered (callback-id) nil
449 (callback-id unsigned-int)
56ccd5b7 450 (%accel-map-foreach-callback callback))
eacab64f 451
452(defun accel-map-foreach (function &optional (filter-p t))
453 (with-callback-function (id function)
454 (if filter-p
455 (%accel-map-foreach id)
456 (%accel-map-foreach-unfiltered id))))
457
458(defbinding accel-map-add-filter () nil
459 (filter string))
460
31700e82 461(defbinding accel-map-get () accel-map)
462
463(defbinding accel-map-lock-path () nil
464 (path string))
465
466(defbinding accel-map-unlock-path () nil
467 (path string))
468
469
470
eacab64f 471;;; Accessibility
d76e9fca 472
473(defbinding accessible-connect-widget-destroyed () nil
474 (accessible accessible))
475
476
0f476ab5 477;;; Adjustment
560af5c5 478
d76e9fca 479(defmethod initialize-instance ((adjustment adjustment) &key value)
1047e159 480 (prog1
481 (call-next-method)
482 ;; we need to make sure that the value is set last, otherwise it
d76e9fca 483 ;; may be outside current limits and ignored
1047e159 484 (when value
485 (setf (slot-value adjustment 'value) value))))
486
487
0f476ab5 488(defbinding adjustment-changed () nil
489 (adjustment adjustment))
490
491(defbinding adjustment-value-changed () nil
492 (adjustment adjustment))
493
494(defbinding adjustment-clamp-page () nil
495 (adjustment adjustment)
496 (lower single-float)
497 (upper single-float))
560af5c5 498
0f476ab5 499
68f519e0 500;;; Alignment
501
502(defbinding alignment-set () nil
503 (alognment alignment)
504 (x-align single-float)
505 (y-align single-float)
506 (x-scale single-float)
507 (y-scale single-float))
508
509(defbinding alignment-get-padding () nil
510 (alognment alignment)
511 (top unsigned-int :out)
512 (bottom unsigned-int :out)
513 (left unsigned-int :out)
514 (right unsigned-int :out))
515
516(defbinding alignment-set-padding () nil
517 (alognment alignment)
518 (top unsigned-int)
519 (bottom unsigned-int)
520 (left unsigned-int)
521 (right unsigned-int))
522
523
0f476ab5 524;;; Aspect frame
525
526
527;;; Bin
560af5c5 528
529(defun (setf bin-child) (child bin)
0f476ab5 530 (when-bind (current-child (bin-child bin))
531 (container-remove bin current-child))
560af5c5 532 (container-add bin child)
533 child)
534
4c371500 535(defmethod compute-signal-function ((bin bin) signal function object args)
14c94516 536 (declare (ignore signal))
537 (if (eq object :child)
4c371500 538 #'(lambda (&rest emission-args)
539 (apply function (bin-child bin) (nconc (rest emission-args) args)))
cb4bf772 540 (call-next-method)))
0f476ab5 541
542
543;;; Box
544
545(defbinding box-pack-start () nil
546 (box box)
547 (child widget)
548 (expand boolean)
549 (fill boolean)
550 (padding unsigned-int))
551
552(defbinding box-pack-end () nil
553 (box box)
554 (child widget)
555 (expand boolean)
556 (fill boolean)
557 (padding unsigned-int))
558
d76e9fca 559(defun box-pack (box child &key end (expand t) (fill t) (padding 0))
1a1949c7 560 (if end
f5b67f2b 561 (box-pack-end box child expand fill padding)
562 (box-pack-start box child expand fill padding)))
0f476ab5 563
564(defbinding box-reorder-child () nil
565 (box box)
566 (child widget)
567 (position int))
568
569(defbinding box-query-child-packing () nil
570 (box box)
571 (child widget)
572 (expand boolean :out)
573 (fill boolean :out)
574 (padding unsigned-int :out)
575 (pack-type pack-type :out))
576
577(defbinding box-set-child-packing () nil
578 (box box)
579 (child widget)
580 (expand boolean)
581 (fill boolean)
582 (padding unsigned-int)
583 (pack-type pack-type))
584
585
586
560af5c5 587;;; Button
588
d76e9fca 589(defmethod initialize-instance ((button button) &rest initargs &key stock)
590 (if stock
8ab0db90 591 (apply #'call-next-method button
592 :label stock :use-stock t :use-underline t initargs)
d76e9fca 593 (call-next-method)))
594
595
bbaeff4b 596(defbinding button-pressed () nil
560af5c5 597 (button button))
598
0f476ab5 599(defbinding button-released () nil
600 (button button))
601
602(defbinding button-clicked () nil
603 (button button))
604
605(defbinding button-enter () nil
606 (button button))
607
608(defbinding button-leave () nil
609 (button button))
610
611
612
613;;; Calendar
614
615(defbinding calendar-select-month () int
616 (calendar calendar)
617 (month unsigned-int)
618 (year unsigned-int))
619
620(defbinding calendar-select-day () nil
621 (calendar calendar)
622 (day unsigned-int))
623
624(defbinding calendar-mark-day () int
625 (calendar calendar)
626 (day unsigned-int))
627
628(defbinding calendar-unmark-day () int
629 (calendar calendar)
630 (day unsigned-int))
631
632(defbinding calendar-clear-marks () nil
633 (calendar calendar))
634
d76e9fca 635(defbinding calendar-get-date () nil
0f476ab5 636 (calendar calendar)
637 (year unsigned-int :out)
638 (month unsigned-int :out)
639 (day unsigned-int :out))
640
641(defbinding calendar-freeze () nil
642 (calendar calendar))
643
644(defbinding calendar-thaw () nil
645 (calendar calendar))
646
647
0f476ab5 648;;; Check menu item
649
650(defbinding check-menu-item-toggled () nil
651 (check-menu-item check-menu-item))
652
653
0f476ab5 654;;; Color selection
655
656(defbinding (color-selection-is-adjusting-p
657 "gtk_color_selection_is_adjusting") () boolean
658 (colorsel color-selection))
659
660
661
662;;; Color selection dialog -- no functions
663
664
665
1a1949c7 666;;;; Combo Box
0f476ab5 667
d76e9fca 668(defmethod initialize-instance ((combo-box combo-box) &rest initargs
669 &key model content active)
670 (remf initargs :active)
671 (if model
672 (apply #'call-next-method combo-box initargs)
673 (progn
674 (apply #'call-next-method combo-box
675 :model (make-instance 'list-store :column-types '(string))
676 initargs)
677 (unless (typep combo-box 'combo-box-entry)
678 (let ((cell (make-instance 'cell-renderer-text)))
679 (cell-layout-pack combo-box cell :expand t)
680 (cell-layout-add-attribute combo-box cell :text 0)))))
681 (when content
682 (mapc #'(lambda (text)
683 (combo-box-append-text combo-box text))
684 content))
685 (when active
686 (setf (combo-box-active combo-box) active)))
687
1a1949c7 688
689;; (defmethod shared-initialize :after ((combo-box combo-box) names &key active)
690;; (when active
691;; (signal-emit combo-box 'changed)))
692
693(defbinding combo-box-append-text () nil
694 (combo-box combo-box)
695 (text string))
696
697(defbinding combo-box-insert-text () nil
698 (combo-box combo-box)
699 (position int)
700 (text string))
701
702(defbinding combo-box-prepend-text () nil
703 (combo-box combo-box)
704 (text string))
705
8ab0db90 706#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1a1949c7 707(defbinding combo-box-get-active-text () string
708 (combo-box combo-box))
0f476ab5 709
1a1949c7 710(defbinding combo-box-popup () nil
711 (combo-box combo-box))
0f476ab5 712
1a1949c7 713(defbinding combo-box-popdown () nil
714 (combo-box combo-box))
715
716
717
718;;;; Combo Box Entry
719
d76e9fca 720(defmethod initialize-instance ((combo-box-entry combo-box-entry) &key model)
1a1949c7 721 (call-next-method)
722 (unless model
723 (setf (combo-box-entry-text-column combo-box-entry) 0)))
0f476ab5 724
725
48da76bf 726;;;; Dialog
0f476ab5 727
c49be931 728(defmethod shared-initialize ((dialog dialog) names &rest initargs
729 &key button buttons)
8ab0db90 730 (declare (ignore names button buttons))
c49be931 731 (prog1
732 (call-next-method)
733 (initial-apply-add dialog #'dialog-add-button initargs :button :buttons)))
48da76bf 734
0f476ab5 735
14c94516 736(defun dialog-response-id (dialog response &optional create-p error-p)
737 "Returns a numeric response id"
738 (if (typep response 'response-type)
739 (response-type-to-int response)
8ab0db90 740 (let ((responses (user-data dialog 'responses)))
14c94516 741 (cond
742 ((and responses (position response responses :test #'equal)))
743 (create-p
1047e159 744 (cond
14c94516 745 (responses
746 (vector-push-extend response responses)
747 (1- (length responses)))
1047e159 748 (t
749 (setf
8ab0db90 750 (user-data dialog 'responses)
14c94516 751 (make-array 1 :adjustable t :fill-pointer t
752 :initial-element response))
1047e159 753 0)))
754 (error-p
14c94516 755 (error "Invalid response: ~A" response))))))
0f476ab5 756
14c94516 757(defun dialog-find-response (dialog id)
758 "Finds a symbolic response given a numeric id"
759 (if (< id 0)
760 (int-to-response-type id)
8ab0db90 761 (aref (user-data dialog 'responses) id)))
14c94516 762
763
764(defmethod compute-signal-id ((dialog dialog) signal)
765 (if (dialog-response-id dialog signal)
766 (ensure-signal-id 'response dialog)
767 (call-next-method)))
768
4c371500 769(defmethod compute-signal-function ((dialog dialog) signal function object args)
770 (declare (ignore function object args))
14c94516 771 (let ((callback (call-next-method))
772 (id (dialog-response-id dialog signal)))
773 (if id
774 #'(lambda (dialog response)
775 (when (= response id)
776 (funcall callback dialog)))
777 callback)))
0f476ab5 778
48da76bf 779(defbinding dialog-run () nil
780 (dialog dialog))
0f476ab5 781
14c94516 782(defbinding dialog-response (dialog response) nil
0f476ab5 783 (dialog dialog)
14c94516 784 ((dialog-response-id dialog response nil t) int))
0f476ab5 785
786
787(defbinding %dialog-add-button () button
788 (dialog dialog)
789 (text string)
14c94516 790 (response-id int))
0f476ab5 791
1047e159 792(defun dialog-add-button (dialog label &optional (response label)
793 &key default object after)
40b2615c 794 "Adds a button to the dialog."
14c94516 795 (let* ((signal (if (functionp response)
796 label
797 response))
798 (id (dialog-response-id dialog signal t))
799 (button (%dialog-add-button dialog label id)))
1047e159 800 (when (functionp response)
14c94516 801 (signal-connect dialog signal response :object object :after after))
1047e159 802 (when default
14c94516 803 (%dialog-set-default-response dialog id))
0f476ab5 804 button))
805
806
14c94516 807(defbinding %dialog-add-action-widget () nil
0f476ab5 808 (dialog dialog)
809 (action-widget widget)
14c94516 810 (response-id int))
0f476ab5 811
1047e159 812(defun dialog-add-action-widget (dialog widget &optional (response widget)
813 &key default object after)
14c94516 814 (let* ((signal (if (functionp response)
815 widget
816 response))
817 (id (dialog-response-id dialog signal t)))
818 (unless (widget-hidden-p widget)
819 (widget-show widget))
820 (%dialog-add-action-widget dialog widget id)
1047e159 821 (when (functionp response)
14c94516 822 (signal-connect dialog signal response :object object :after after))
1047e159 823 (when default
14c94516 824 (%dialog-set-default-response dialog id))
0f476ab5 825 widget))
0f476ab5 826
0f476ab5 827
48da76bf 828(defbinding %dialog-set-default-response () nil
829 (dialog dialog)
14c94516 830 (response-id int))
0f476ab5 831
14c94516 832(defun dialog-set-default-response (dialog response)
48da76bf 833 (%dialog-set-default-response
14c94516 834 dialog (dialog-response-id dialog response nil t)))
0f476ab5 835
14c94516 836(defbinding dialog-set-response-sensitive (dialog response sensitive) nil
48da76bf 837 (dialog dialog)
14c94516 838 ((dialog-response-id dialog response nil t) int)
48da76bf 839 (sensitive boolean))
0f476ab5 840
8ab0db90 841#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
647c99e5 842(defbinding alternative-dialog-button-order-p (&optional screen) boolean
843 (screen (or null gdk:screen)))
40b2615c 844
8ab0db90 845#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
40b2615c 846(defbinding (dialog-set-alternative-button-order
5a87235c 847 "gtk_dialog_set_alternative_button_order_from_array")
848 (dialog new-order) nil
40b2615c 849 (dialog dialog)
850 ((length new-order) int)
14c94516 851 ((map 'vector #'(lambda (response)
852 (dialog-response-id dialog response nil t))
40b2615c 853 new-order) (vector int)))
0f476ab5 854
48da76bf 855
8ab0db90 856#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
bdc0e300 857(progn
858 (defbinding %dialog-get-response-for-widget () int
859 (dialog dialog)
860 (widget widget))
861
862 (defun dialog-get-response-for-widget (dialog widget)
863 (dialog-find-response dialog (dialog-get-response-for-widget dialog widget))))
864
865
48da76bf 866(defmethod container-add ((dialog dialog) (child widget) &rest args)
1047e159 867 (apply #'container-add (dialog-vbox dialog) child args))
48da76bf 868
14c94516 869
48da76bf 870(defmethod container-remove ((dialog dialog) (child widget))
1047e159 871 (container-remove (dialog-vbox dialog) child))
0f476ab5 872
48da76bf 873(defmethod container-children ((dialog dialog))
1047e159 874 (container-children (dialog-vbox dialog)))
48da76bf 875
876(defmethod (setf container-children) (children (dialog dialog))
1047e159 877 (setf (container-children (dialog-vbox dialog)) children))
560af5c5 878
560af5c5 879
e3cdfeea 880;;; Drawing Area
881
882(defun drawing-area-scroll (drawing-area dx dy)
883 (gdk:window-scroll (widget-window drawing-area) dx dy))
884
885
aaa6e6cb 886;;; Entry
560af5c5 887
aaa6e6cb 888(defbinding entry-get-layout-offsets () nil
889 (entry entry)
890 (x int :out)
891 (y int :out))
560af5c5 892
d76e9fca 893(defbinding entry-layout-index-to-text-index () int
894 (entry entry)
895 (layout-index int))
896
897(defbinding entry-text-index-to-layout-index () int
898 (entry entry)
899 (text-index int))
900
560af5c5 901
f45fd227 902;;; Entry Completion
903
56ccd5b7 904(define-callback-marshal %entry-completion-match-callback boolean
905 (entry-completion string tree-iter))
f45fd227 906
907(defbinding entry-completion-set-match-func (completion function) nil
908 (completion entry-completion)
56ccd5b7 909 (%entry-completion-match-callback callback)
f45fd227 910 ((register-callback-function function) unsigned-int)
56ccd5b7 911 (user-data-destroy-callback callback))
f45fd227 912
913(defbinding entry-completion-complete () nil
914 (completion entry-completion))
915
8ab0db90 916#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
f45fd227 917(defbinding entry-completion-insert-prefix () nil
918 (completion entry-completion))
919
920(defbinding entry-completion-insert-action-text () nil
921 (completion entry-completion)
922 (index int)
923 (text string))
924
925(defbinding entry-completion-insert-action-markup () nil
926 (completion entry-completion)
927 (index int)
928 (markup string))
929
930(defbinding entry-completion-delete-action () nil
931 (completion entry-completion)
932 (index int))
933
934
68f519e0 935;;; File Chooser
936
937(defmethod initialize-instance ((file-chooser file-chooser) &rest initargs
938 &key filter filters shortcut-folder
939 shortcut-folders shortcut-folder-uti
940 shortcut-folder-uris)
941 (declare (ignore filter filters shortcut-folder shortcut-folders
942 shortcut-folder-uti shortcut-folder-uris))
943 (prog1
944 (call-next-method)
945 (initial-add file-chooser #'file-chooser-add-filter
946 initargs :filer :filters)
947 (initial-add file-chooser #'file-chooser-add-shortcut-folder
948 initargs :shortcut-folder :shortcut-folders)
949 (initial-add file-chooser #'file-chooser-add-shortcut-folder-uri
950 initargs :shortcut-folder-uri :shortcut-folders-uris)))
951
952
953(defbinding file-chooser-select-filename () boolean
954 (file-chooser file-chooser)
955 (filename string))
956
957(defbinding file-chooser-unselect-filename () nil
958 (file-chooser file-chooser)
959 (filename string))
960
961(defbinding file-chooser-select-all () boolean
962 (file-chooser file-chooser))
963
964(defbinding file-chooser-unselect-all () boolean
965 (file-chooser file-chooser))
966
967(defbinding file-chooser-get-filenames () (gslist string)
968 (file-chooser file-chooser))
969
970(defbinding file-chooser-select-uri () boolean
971 (file-chooser file-chooser)
972 (uri string))
973
974(defbinding file-chooser-unselect-uri () nil
975 (file-chooser file-chooser)
976 (uri string))
977
978(defbinding file-chooser-get-uris () (gslist string)
979 (file-chooser file-chooser))
980
981(defbinding file-chooser-add-filter () nil
982 (file-chooser file-chooser)
983 (filter file-filter))
984
985(defbinding file-chooser-remove-filter () nil
986 (file-chooser file-chooser)
987 (filter file-filter))
988
989(defbinding file-chooser-list-filters () (gslist file-filter)
990 (file-chooser file-chooser))
991
992(defbinding file-chooser-add-shortcut-folder () boolean
993 (file-chooser file-chooser)
994 (folder string)
995 (nil null))
996
997(defbinding file-chooser-remove-shortcut-folder () nil
998 (file-chooser file-chooser)
999 (folder string)
1000 (nil null))
1001
1002(defbinding file-chooser-list-shortcut-folders () (gslist string)
1003 (file-chooser file-chooser))
1004
1005(defbinding file-chooser-add-shortcut-folder-uri () boolean
1006 (file-chooser file-chooser)
1007 (uri string)
1008 (nil null))
1009
1010(defbinding file-chooser-remove-shortcut-folder-uri () nil
1011 (file-chooser file-chooser)
1012 (uri string)
1013 (nil null))
1014
1015(defbinding file-chooser-list-shortcut-folder-uris () (gslist string)
1016 (file-chooser file-chooser))
1017
1018
1019;;; File Filter
1020
1021(defmethod initialize-instance ((file-filter file-filter) &rest initargs
1022 &key mime-type mime-types pattern patterns
1023 pixbuf-formats)
1024 (declare (ignore mime-type mime-types pattern patterns))
1025 (prog1
1026 (call-next-method)
1027 (when pixbuf-formats
8ab0db90 1028 #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1029 (warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
1030 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1031 (file-filter-add-pixbuf-formats file-filter))
68f519e0 1032 (initial-add file-filter #'file-filter-add-mime-type
1033 initargs :mime-type :mime-types)
1034 (initial-add file-filter #'file-filter-add-pattern
1035 initargs :pattern :patterns)))
1036
1037
1038(defbinding file-filter-add-mime-type () nil
1039 (filter file-filter)
1040 (mime-type string))
1041
1042(defbinding file-filter-add-pattern () nil
1043 (filter file-filter)
1044 (pattern string))
1045
8ab0db90 1046#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
68f519e0 1047(defbinding file-filter-add-pixbuf-formats () nil
647c99e5 1048 (filter file-filter))
68f519e0 1049
56ccd5b7 1050(define-callback-marshal %file-filter-callback boolean (file-filter-info))
68f519e0 1051
73572c12 1052(defbinding file-filter-add-custom (filter needed function) nil
68f519e0 1053 (filter file-filter)
1054 (needed file-filter-flags)
56ccd5b7 1055 (%file-filter-callback callback)
68f519e0 1056 ((register-callback-function function) unsigned-int)
56ccd5b7 1057 (user-data-destroy-callback callback))
68f519e0 1058
1059(defbinding file-filter-get-needed () file-filter-flags
1060 (filter file-filter))
1061
1062(defbinding file-filter-filter () boolean
1063 (filter file-filter)
1064 (filter-info file-filter-info))
1065
1066
1067
1047e159 1068;;; Image
1069
1070(defbinding image-set-from-file () nil
1071 (image image)
1072 (filename pathname))
1073
d76e9fca 1074(defmethod (setf image-pixmap) ((data vector) (image image))
1075 (multiple-value-bind (pixmap mask) (gdk:pixmap-create data)
1076 (setf (image-pixmap image) pixmap)
1077 (setf (image-mask image) mask)))
1078
1079(defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
1080 (cond
1081 ((typep pixmap 'vector)
1082 (multiple-value-bind (pixmap mask) (gdk:pixmap-create pixmap)
1083 (apply #'call-next-method image :pixmap pixmap :mask mask initargs)))
1084 (file
1085 (prog1
1086 (call-next-method)
1087 (image-set-from-file image file)))
1088 ((call-next-method))))
1047e159 1089
cb4bf772 1090(defun create-image-widget (source &optional mask)
d76e9fca 1091 (etypecase source
1092 (gdk:pixbuf (make-instance 'image :pixbuf source))
1093 (string (make-instance 'image :stock source))
1094 (pathname (make-instance 'image :file source))
1095 ((or list vector) (make-instance 'image :pixmap source))
1096 (gdk:pixmap (make-instance 'image :pixmap source :mask mask))))
1047e159 1097
8ab0db90 1098#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
bdc0e300 1099(defbinding image-clear () nil
1100 (image image))
1101
1102
1047e159 1103
d76e9fca 1104;;; Image menu item
1047e159 1105
d76e9fca 1106(defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
1107 (if (and image (not (typep image 'widget)))
cb4bf772 1108 (apply #'call-next-method item :image (create-image-widget image) initargs)
d76e9fca 1109 (call-next-method)))
1047e159 1110
d76e9fca 1111
1112(defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
1113 (setf (slot-value item 'image) widget))
1114
1115(defmethod (setf image-menu-item-image) (image (item image-menu-item))
cb4bf772 1116 (setf (image-menu-item-image item) (create-image-widget image)))
1047e159 1117
560af5c5 1118
0f476ab5 1119;;; Label
560af5c5 1120
881fe3c3 1121(defmethod shared-initialize ((label label) names &key pattern)
1122 (declare (ignore names))
1123 (call-next-method)
1124 (when pattern
1125 (setf (label-pattern label) pattern)))
1126
aaa6e6cb 1127(defbinding label-get-layout-offsets () nil
1047e159 1128 (label label)
aaa6e6cb 1129 (x int :out)
1130 (y int :out))
1131
0f476ab5 1132(defbinding label-select-region () nil
1133 (label label)
1134 (start int)
1135 (end int))
560af5c5 1136
1047e159 1137(defbinding label-get-selection-bounds () boolean
aaa6e6cb 1138 (label label)
1139 (start int :out)
1140 (end int :out))
f36ca6af 1141
560af5c5 1142
1143
1144;;; Radio button
1145
e5b416f0 1146(defbinding %radio-button-get-group () pointer
d520140e 1147 (radio-button radio-button))
1148
bbaeff4b 1149(defbinding %radio-button-set-group () nil
d520140e 1150 (radio-button radio-button)
1151 (group pointer))
560af5c5 1152
cb4bf772 1153(defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button))
d520140e 1154 "Add BUTTON1 to the group which BUTTON2 belongs to."
1155 (%radio-button-set-group button1 (%radio-button-get-group button2)))
1156
a5522de5 1157(defun %add-activate-callback (widget signal function object after)
1158 (if object
1159 (signal-connect widget signal
1160 #'(lambda (object)
1161 (when (slot-value widget 'active)
1162 (funcall function object (slot-value widget 'value))))
1163 :object object :after after)
1164 (signal-connect widget signal
1165 #'(lambda ()
1166 (when (slot-value widget 'active)
1167 (funcall function (slot-value widget 'value))))
1168 :after after)))
1169
1170(defmethod activate-radio-widget ((button radio-button))
1171 (signal-emit button 'clicked))
1172
c78ef85c 1173(defgeneric add-activate-callback (action function &key object after))
1174
a5522de5 1175(defmethod add-activate-callback ((button radio-button) function &key object after)
1176 (%add-activate-callback button 'clicked function object after))
1177
d76e9fca 1178(defmethod initialize-instance ((button radio-button) &key group)
1179 (prog1
1180 (call-next-method)
1181 (when group
cb4bf772 1182 (add-to-radio-group button group))))
560af5c5 1183
1184
560af5c5 1185;;; Item
1186
bbaeff4b 1187(defbinding item-select () nil
560af5c5 1188 (item item))
1189
bbaeff4b 1190(defbinding item-deselect () nil
560af5c5 1191 (item item))
1192
bbaeff4b 1193(defbinding item-toggle () nil
560af5c5 1194 (item item))
1195
1196
1197
1198;;; Menu item
1199
d76e9fca 1200(defmethod initialize-instance ((item menu-item) &key label)
1201 (prog1
1202 (call-next-method)
1203 (when label
1204 (setf (menu-item-label item) label))))
1205
1206
f36ca6af 1207(defun (setf menu-item-label) (label menu-item)
1208 (make-instance 'accel-label
1209 :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
d76e9fca 1210 :use-underline (menu-item-use-underline-p menu-item)
1211 :visible t :parent menu-item)
f36ca6af 1212 label)
560af5c5 1213
f5b67f2b 1214(defun menu-item-label (menu-item)
d76e9fca 1215 (when (and (slot-boundp menu-item 'child)
1216 (typep (bin-child menu-item) 'label))
1217 (label-label (bin-child menu-item))))
f5b67f2b 1218
d76e9fca 1219(defbinding menu-item-remove-submenu () nil
f36ca6af 1220 (menu-item menu-item))
560af5c5 1221
f5b67f2b 1222(defbinding menu-item-set-accel-path () nil
1223 (menu-item menu-item)
1224 (accel-path string))
1225
bbaeff4b 1226(defbinding menu-item-select () nil
f36ca6af 1227 (menu-item menu-item))
560af5c5 1228
bbaeff4b 1229(defbinding menu-item-deselect () nil
f36ca6af 1230 (menu-item menu-item))
560af5c5 1231
bbaeff4b 1232(defbinding menu-item-activate () nil
f36ca6af 1233 (menu-item menu-item))
560af5c5 1234
f5b67f2b 1235(defbinding menu-item-toggle-size-request () nil
1236 (menu-item menu-item)
1237 (requisition int :out))
1238
1239(defbinding menu-item-toggle-size-allocate () nil
1240 (menu-item menu-item)
1241 (allocation int))
1242
560af5c5 1243
d76e9fca 1244;;; Menu tool button
1245
8ab0db90 1246#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
647c99e5 1247(defbinding menu-tool-button-set-arrow-tooltip () nil
d76e9fca 1248 (menu-tool-button menu-tool-button)
1249 (tooltips tooltips)
1250 (tip-text string)
1251 (tip-private string))
1252
1253
f4267180 1254;;; Message dialog
1255
9176d301 1256(defmethod allocate-foreign ((dialog message-dialog) &key (message-type :info)
1257 (buttons :close) flags transient-parent)
1258 (%message-dialog-new transient-parent flags message-type buttons))
1259
1260
8ab0db90 1261(defmethod shared-initialize ((dialog message-dialog) names &key text
1262 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1263 secondary-text)
9176d301 1264 (declare (ignore names))
7a2e0799 1265 (when text
1266 (message-dialog-set-markup dialog text))
8ab0db90 1267 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
7a2e0799 1268 (when secondary-text
1269 (message-dialog-format-secondary-markup dialog secondary-text))
1270 (call-next-method))
f4267180 1271
1272
1273(defbinding %message-dialog-new () pointer
1274 (parent (or null window))
1275 (flags dialog-flags)
1276 (type message-type)
1277 (buttons buttons-type)
7a2e0799 1278 (nil null))
f4267180 1279
1280(defbinding message-dialog-set-markup () nil
1281 (message-dialog message-dialog)
1282 (markup string))
1283
8ab0db90 1284#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
f4267180 1285(defbinding message-dialog-format-secondary-text () nil
1286 (message-dialog message-dialog)
1287 (text string))
1288
8ab0db90 1289#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
f4267180 1290(defbinding message-dialog-format-secondary-markup () nil
1291 (message-dialog message-dialog)
1292 (markup string))
1293
1294
560af5c5 1295
f36ca6af 1296;;; Radio menu item
560af5c5 1297
e5b416f0 1298(defbinding %radio-menu-item-get-group () pointer
d520140e 1299 (radio-menu-item radio-menu-item))
1300
bbaeff4b 1301(defbinding %radio-menu-item-set-group () nil
d520140e 1302 (radio-menu-item radio-menu-item)
1303 (group pointer))
1304
a5522de5 1305(defmethod activate-radio-widget ((item radio-menu-item))
1306 (menu-item-activate item))
1307
cb4bf772 1308(defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item))
d520140e 1309 "Add ITEM1 to the group which ITEM2 belongs to."
1310 (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
1311
a5522de5 1312(defmethod add-activate-callback ((item radio-menu-item) function &key object after)
1313 (%add-activate-callback item 'activate function object after))
1314
d76e9fca 1315(defmethod initialize-instance ((item radio-menu-item) &key group)
f5b67f2b 1316 (prog1
1317 (call-next-method)
d76e9fca 1318 (when group
cb4bf772 1319 (add-to-radio-group item group))))
1320
d520140e 1321
560af5c5 1322
d76e9fca 1323;;; Radio tool button
1324
1325(defbinding %radio-tool-button-get-group () pointer
1326 (radio-tool-button radio-tool-button))
1327
1328(defbinding %radio-tool-button-set-group () nil
1329 (radio-tool-button radio-tool-button)
1330 (group pointer))
1331
a5522de5 1332(defmethod activate-radio-widget ((button radio-tool-button))
1333 (signal-emit button 'clicked))
1334
cb4bf772 1335(defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button))
d76e9fca 1336 "Add BUTTON1 to the group which BUTTON2 belongs to."
1337 (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2)))
a5522de5 1338(defmethod add-activate-callback ((button radio-tool-button) function &key object after)
1339 (%add-activate-callback button 'clicked function object after))
d76e9fca 1340
1341(defmethod initialize-instance ((button radio-tool-button) &key group)
1342 (prog1
1343 (call-next-method)
1344 (when group
cb4bf772 1345 (add-to-radio-group button group))))
1346
d76e9fca 1347
560af5c5 1348
aaa6e6cb 1349;;; Toggle button
1350
1351(defbinding toggle-button-toggled () nil
1352 (toggle-button toggle-button))
1353
1354
560af5c5 1355;;; Window
1356
c49be931 1357(defmethod initialize-instance ((window window) &rest initargs
050f6c9f 1358 &key display accel-group accel-groups)
c49be931 1359 (declare (ignore accel-group accel-groups))
1360 (prog1
050f6c9f 1361 (if display
1362 (apply #'call-next-method
f5c99598 1363 window :screen (gdk:display-get-default-screen (gdk:ensure-display display)) initargs)
050f6c9f 1364 (call-next-method))
c49be931 1365 (initial-add window #'window-add-accel-group
1366 initargs :accel-group :accel-groups)))
73d58e01 1367
5a87235c 1368#-debug-ref-counting
1369(defmethod print-object ((window window) stream)
1370 (if (and
1371 (proxy-valid-p window)
1372 (slot-boundp window 'title)
1373 (not (zerop (length (window-title window)))))
1374 (print-unreadable-object (window stream :type t :identity nil)
1375 (format stream "~S at 0x~X"
8ab0db90 1376 (window-title window) (pointer-address (foreign-location window))))
5a87235c 1377 (call-next-method)))
73d58e01 1378
7625ebd8 1379(defbinding window-set-wmclass () nil
560af5c5 1380 (window window)
1381 (wmclass-name string)
1382 (wmclass-class string))
1383
bbaeff4b 1384(defbinding window-add-accel-group () nil
560af5c5 1385 (window window)
1386 (accel-group accel-group))
1387
bbaeff4b 1388(defbinding window-remove-accel-group () nil
560af5c5 1389 (window window)
1390 (accel-group accel-group))
1391
bbaeff4b 1392(defbinding window-activate-focus () int
560af5c5 1393 (window window))
1394
bbaeff4b 1395(defbinding window-activate-default () int
560af5c5 1396 (window window))
1397
7625ebd8 1398(defbinding window-set-default-size (window width height) int
560af5c5 1399 (window window)
7625ebd8 1400 ((or width -1) int)
1401 ((or height -1) int))
560af5c5 1402
4d16221f 1403(defbinding %window-set-geometry-hints () nil
1404 (window window)
d29387c6 1405 (widget (or widget null))
4d16221f 1406 (geometry gdk:geometry)
1407 (geometry-mask gdk:window-hints))
1408
d29387c6 1409(defun window-set-geometry-hints (window &key widget min-width min-height
4d16221f 1410 max-width max-height base-width base-height
d29387c6 1411 width-inc height-inc gravity
1412 aspect (min-aspect aspect) (max-aspect aspect))
4d16221f 1413 (let ((geometry (make-instance 'gdk:geometry
1414 :min-width (or min-width -1)
1415 :min-height (or min-height -1)
1416 :max-width (or max-width -1)
1417 :max-height (or max-height -1)
1418 :base-width (or base-width 0)
1419 :base-height (or base-height 0)
1420 :width-inc (or width-inc 0)
1421 :height-inc (or height-inc 0)
1422 :min-aspect (or min-aspect 0)
d29387c6 1423 :max-aspect (or max-aspect 0)))
4d16221f 1424 (mask ()))
d29387c6 1425 (when (or min-width min-height)
4d16221f 1426 (push :min-size mask))
d29387c6 1427 (when (or max-width max-height)
4d16221f 1428 (push :max-size mask))
1429 (when (or base-width base-height)
1430 (push :base-size mask))
1431 (when (or width-inc height-inc)
1432 (push :resize-inc mask))
1433 (when (or min-aspect max-aspect)
1434 (push :aspect mask))
d29387c6 1435 (when gravity
1436 (push :win-gravity mask)
1437 (setf (gdk:geometry-gravity geometry) gravity))
1438 (%window-set-geometry-hints window widget geometry mask)))
560af5c5 1439
73d58e01 1440(defbinding window-list-toplevels () (glist (copy-of window))
1441 "Returns a list of all existing toplevel windows.")
7625ebd8 1442
1443(defbinding window-add-mnemonic (window key target) nil
1444 (window window)
1445 ((gdk:keyval-from-name key) unsigned-int)
1446 (target widget))
1447
1448(defbinding window-remove-mnemonic (window key target) nil
1449 (window window)
1450 ((gdk:keyval-from-name key) unsigned-int)
1451 (target widget))
1452
1453(defbinding window-mnemonic-activate (window key modifier) nil
1454 (window window)
1455 ((gdk:keyval-from-name key) unsigned-int)
1456 (modifier gdk:modifier-type))
1457
4d16221f 1458(defbinding window-activate-key () boolean
1459 (window window)
1460 (event gdk:key-event))
1461
1462(defbinding window-propagate-key-event () boolean
1463 (window window)
1464 (event gdk:key-event))
1465
8ab0db90 1466#?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
7625ebd8 1467(defbinding window-present () nil
1468 (window window))
1469
8ab0db90 1470#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
bdc0e300 1471(progn
1472 (defbinding %window-present () nil
1473 (window window))
1474
6e8bf4cf 1475 (defbinding %window-present-with-time () nil
bdc0e300 1476 (window window)
1477 (timespamp unsigned-int))
1478
1479 (defun window-present (window &optional timestamp)
1480 (if timestamp
6e8bf4cf 1481 (%window-present-with-time window timestamp)
bdc0e300 1482 (%window-present window))))
1483
7625ebd8 1484(defbinding window-iconify () nil
1485 (window window))
1486
1487(defbinding window-deiconify () nil
1488 (window window))
1489
1490(defbinding window-stick () nil
1491 (window window))
1492
1493(defbinding window-unstick () nil
1494 (window window))
1495
1496(defbinding window-maximize () nil
1497 (window window))
1498
1499(defbinding window-unmaximize () nil
1500 (window window))
1501
4d16221f 1502(defbinding window-fullscreen () nil
1503 (window window))
1504
1505(defbinding window-unfullscreen () nil
1506 (window window))
1507
1508(defbinding window-set-keep-above () nil
1509 (window window)
1510 (setting boolean))
1511
1512(defbinding window-set-keep-below () nil
1513 (window window)
1514 (setting boolean))
1515
7625ebd8 1516(defbinding window-begin-resize-drag () nil
1517 (window window)
1518 (edge gdk:window-edge)
1519 (button int)
1520 (root-x int) (root-y int)
9adccb27 1521 (timestamp unsigned-int))
7625ebd8 1522
1523(defbinding window-begin-move-drag () nil
1524 (window window)
1525 (edge gdk:window-edge)
1526 (button int)
1527 (root-x int) (root-y int)
9adccb27 1528 (timestamp unsigned-int))
7625ebd8 1529
1530(defbinding window-set-frame-dimensions () nil
1531 (window window)
1532 (left int) (top int) (rigth int) (bottom int))
1533
7625ebd8 1534(defbinding %window-get-default-size () nil
1535 (window window)
1536 (width int :out)
1537 (height int :out))
1538
1539(defun window-get-default-size (window)
1540 (multiple-value-bind (width height) (%window-get-default-size window)
1541 (values (unless (= width -1) width) (unless (= height -1) height))))
1542
1543(defbinding window-get-frame-dimensions () nil
1544 (window window)
1545 (left int :out) (top int :out) (rigth int :out) (bottom int :out))
1546
190c2bcf 1547(defbinding %window-get-icon-list () (glist (copy-of gdk:pixbuf))
7625ebd8 1548 (window window))
1549
7625ebd8 1550(defbinding window-get-position () nil
1551 (window window)
1552 (root-x int :out)
1553 (root-y int :out))
1554
1555(defbinding window-get-size () nil
1556 (window window)
1557 (width int :out)
1558 (height int :out))
1559
1560(defbinding window-move () nil
1561 (window window)
1562 (x int)
1563 (y int))
1564
1565(defbinding window-parse-geometry () boolean
1566 (window window)
1567 (geometry string))
1568
1569(defbinding window-reshow-with-initial-size () nil
1570 (window window))
1571
1572(defbinding window-resize () nil
1573 (window window)
1574 (width int)
1575 (heigth int))
1576
4d16221f 1577(defbinding (window-default-icon-list "gtk_window_get_default_icon_list")
1578 () (glist gdk:pixbuf))
1579
1580(defun window-default-icon ()
1581 (first (window-default-icon-list)))
1582
1583(defbinding %window-set-default-icon-list () nil
1584 (icons (glist gdk:pixbuf)))
1585
1586(defun (setf window-default-icon-list) (icons)
1587 (%window-set-default-icon-list icons)
1588 icons)
1589
1590(defbinding %window-set-default-icon () nil
1591 (icons (glist gdk:pixbuf)))
1592
c78ef85c 1593(defgeneric (setf window-default-icon) (icon))
1594
4d16221f 1595(defmethod (setf window-default-icon) ((icon gdk:pixbuf))
1596 (%window-set-default-icon icon)
1597 icon)
1598
c78ef85c 1599(defgeneric (setf window-group) (group window))
1600
4d16221f 1601(defmethod (setf window-group) ((group window-group) (window window))
1602 (window-group-add-window group window)
1603 group)
1604
1605(defbinding %window-set-default-icon-from-file () boolean
1606 (filename pathname)
1607 (nil null))
1608
1609(defmethod (setf window-default-icon) ((icon-file pathname))
1610 (%window-set-default-icon-from-file icon-file)
1611 icon-file)
1612
1613(defbinding %window-set-icon-from-file () boolean
1614 (window window)
1615 (filename pathname)
1616 (nil null))
1617
1618(defmethod (setf window-icon) ((icon-file pathname) (window window))
1619 (%window-set-icon-from-file window icon-file)
1620 icon-file)
1621
1622(defbinding window-set-auto-startup-notification () nil
1623 (setting boolean))
1624
1625(defbinding decorated-window-init () nil
1626 (window window))
1627
1628(defbinding decorated-window-calculate-frame-size () nil
1629 (window window))
1630
1631(defbinding decorated-window-set-title () nil
7625ebd8 1632 (window window)
4d16221f 1633 (title string))
7625ebd8 1634
4d16221f 1635(defbinding decorated-window-move-resize-window () nil
1636 (window window)
1637 (x int)
1638 (y int)
1639 (width int)
1640 (heigth int))
7625ebd8 1641
1642
4d16221f 1643;;; Window group
560af5c5 1644
4d16221f 1645(defmethod initialize-instance ((window-group window-group) &rest initargs
1646 &key window windows)
1647 (declare (ignore window windows))
1648 (prog1
1649 (call-next-method)
1650 (initial-add window-group #'window-group-add-window
1651 initargs :window :windows)))
560af5c5 1652
560af5c5 1653
4d16221f 1654(defbinding window-group-add-window () nil
1655 (window-group window-group)
1656 (window window))
560af5c5 1657
4d16221f 1658(defbinding window-group-remove-window () nil
1659 (window-group window-group)
1660 (window window))
560af5c5 1661
1662
f36ca6af 1663;;; Scrolled window
560af5c5 1664
560af5c5 1665(defun (setf scrolled-window-scrollbar-policy) (policy window)
1666 (setf (scrolled-window-hscrollbar-policy window) policy)
1667 (setf (scrolled-window-vscrollbar-policy window) policy))
1668
bbaeff4b 1669(defbinding scrolled-window-add-with-viewport () nil
560af5c5 1670 (scrolled-window scrolled-window)
1671 (child widget))
1672
7a2e0799 1673(defmethod shared-initialize ((window scrolled-window) names &key policy)
1674 (declare (ignore names))
1675 (when policy
1676 (setf (slot-value window 'hscrollbar-policy) policy)
1677 (setf (slot-value window 'vscrollbar-policy) policy))
1678 (call-next-method))
d520140e 1679
560af5c5 1680
f36ca6af 1681;;; Statusbar
560af5c5 1682
d76e9fca 1683(defbinding statusbar-get-context-id () unsigned-int
f36ca6af 1684 (statusbar statusbar)
1685 (context-description string))
560af5c5 1686
bbaeff4b 1687(defbinding statusbar-push () unsigned-int
f36ca6af 1688 (statusbar statusbar)
1689 (context-id unsigned-int)
1690 (text string))
560af5c5 1691
bbaeff4b 1692(defbinding statusbar-pop () nil
f36ca6af 1693 (statusbar statusbar)
1694 (context-id unsigned-int))
560af5c5 1695
bbaeff4b 1696(defbinding statusbar-remove () nil
f36ca6af 1697 (statusbar statusbar)
1698 (context-id unsigned-int)
1699 (message-id unsigned-int))
560af5c5 1700
560af5c5 1701
1702
1703;;; Fixed
1704
bbaeff4b 1705(defbinding fixed-put () nil
f36ca6af 1706 (fixed fixed)
1707 (widget widget)
f5b67f2b 1708 (x int) (y int))
560af5c5 1709
bbaeff4b 1710(defbinding fixed-move () nil
f36ca6af 1711 (fixed fixed)
1712 (widget widget)
f5b67f2b 1713 (x int) (y int))
560af5c5 1714
1715
1716
d520140e 1717;;; Notebook
560af5c5 1718
68f519e0 1719(defun %ensure-notebook-position (notebook page)
f5b67f2b 1720 (etypecase page
68f519e0 1721 (position page)
f5b67f2b 1722 (widget (notebook-page-num notebook page t))))
1723
68f519e0 1724(defun %ensure-notebook-child (notebook position)
f5b67f2b 1725 (typecase position
1726 (widget position)
68f519e0 1727 (t (notebook-get-nth-page notebook position))))
f5b67f2b 1728
1729(defbinding (notebook-insert "gtk_notebook_insert_page_menu")
8ab0db90 1730 (notebook position child &optional tab-label menu-label) nil
f36ca6af 1731 (notebook notebook)
1732 (child widget)
1733 ((if (stringp tab-label)
f5b67f2b 1734 (make-instance 'label :label tab-label)
8ab0db90 1735 tab-label) (or null widget))
f36ca6af 1736 ((if (stringp menu-label)
f5b67f2b 1737 (make-instance 'label :label menu-label)
f36ca6af 1738 menu-label) (or null widget))
68f519e0 1739 ((%ensure-notebook-position notebook position) position))
560af5c5 1740
8ab0db90 1741(defun notebook-append (notebook child &optional tab-label menu-label)
f5b67f2b 1742 (notebook-insert notebook :last child tab-label menu-label))
560af5c5 1743
8ab0db90 1744(defun notebook-prepend (notebook child &optional tab-label menu-label)
f5b67f2b 1745 (notebook-insert notebook :first child tab-label menu-label))
560af5c5 1746
f5b67f2b 1747(defbinding notebook-remove-page (notebook page) nil
f36ca6af 1748 (notebook notebook)
68f519e0 1749 ((%ensure-notebook-position notebook page) position))
560af5c5 1750
bbaeff4b 1751(defbinding %notebook-page-num () int
f36ca6af 1752 (notebook notebook)
1753 (child widget))
1754
f5b67f2b 1755(defun notebook-page-num (notebook child &optional error-p)
f36ca6af 1756 (let ((page-num (%notebook-page-num notebook child)))
1757 (if (= page-num -1)
f5b67f2b 1758 (when error-p
68f519e0 1759 (error "~A is not a page in ~A" child notebook))
f36ca6af 1760 page-num)))
1761
bbaeff4b 1762(defbinding notebook-next-page () nil
f36ca6af 1763 (notebook notebook))
560af5c5 1764
bbaeff4b 1765(defbinding notebook-prev-page () nil
f36ca6af 1766 (notebook notebook))
1767
f5b67f2b 1768(defbinding notebook-reorder-child (notebook child position) nil
1769 (notebook notebook)
1770 (child widget)
bdc0e300 1771 ((%ensure-notebook-position notebook position) int))
f5b67f2b 1772
bbaeff4b 1773(defbinding notebook-popup-enable () nil
f36ca6af 1774 (notebook notebook))
1775
bbaeff4b 1776(defbinding notebook-popup-disable () nil
f36ca6af 1777 (notebook notebook))
1778
68f519e0 1779(defbinding notebook-get-nth-page () widget
f5b67f2b 1780 (notebook notebook)
68f519e0 1781 (page position))
f5b67f2b 1782
68f519e0 1783(defun %notebook-current-page (notebook)
1784 (when (slot-boundp notebook 'current-page-num)
1785 (notebook-get-nth-page notebook (notebook-current-page-num notebook))))
f5b67f2b 1786
1787(defun (setf notebook-current-page) (page notebook)
8ab0db90 1788 (setf (notebook-current-page-num notebook) (notebook-page-num notebook page)))
f5b67f2b 1789
1047e159 1790(defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
1791 (notebook page) widget
1792 (notebook notebook)
68f519e0 1793 ((%ensure-notebook-child notebook page) widget))
f5b67f2b 1794
1047e159 1795(defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
6bb23851 1796 (notebook page) (copy-of string)
1047e159 1797 (notebook notebook)
68f519e0 1798 ((%ensure-notebook-child notebook page) widget))
f5b67f2b 1799
1047e159 1800(defbinding %notebook-set-tab-label () nil
1801 (notebook notebook)
1802 (page widget)
1803 (tab-label widget))
1804
1805(defun (setf notebook-tab-label) (tab-label notebook page)
1806 (let ((widget (if (stringp tab-label)
1807 (make-instance 'label :label tab-label)
1808 tab-label)))
68f519e0 1809 (%notebook-set-tab-label notebook (%ensure-notebook-child notebook page) widget)
1047e159 1810 widget))
f5b67f2b 1811
f5b67f2b 1812
1047e159 1813(defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
1814 (notebook page) widget
1815 (notebook notebook)
68f519e0 1816 ((%ensure-notebook-child notebook page) widget))
f5b67f2b 1817
1047e159 1818(defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
6bb23851 1819 (notebook page) (copy-of string)
1047e159 1820 (notebook notebook)
68f519e0 1821 ((%ensure-notebook-child notebook page) widget))
f5b67f2b 1822
1047e159 1823(defbinding %notebook-set-menu-label () nil
1824 (notebook notebook)
1825 (page widget)
1826 (menu-label widget))
1827
1828(defun (setf notebook-menu-label) (menu-label notebook page)
1829 (let ((widget (if (stringp menu-label)
1830 (make-instance 'label :label menu-label)
1831 menu-label)))
68f519e0 1832 (%notebook-set-menu-label notebook (%ensure-notebook-child notebook page) widget)
1047e159 1833 widget))
f5b67f2b 1834
1835
1836(defbinding notebook-query-tab-label-packing (notebook page) nil
f36ca6af 1837 (notebook notebook)
bdc0e300 1838 ((%ensure-notebook-child notebook page) widget)
f36ca6af 1839 (expand boolean :out)
1840 (fill boolean :out)
1841 (pack-type pack-type :out))
1842
f5b67f2b 1843(defbinding notebook-set-tab-label-packing
1844 (notebook page expand fill pack-type) nil
f36ca6af 1845 (notebook notebook)
bdc0e300 1846 ((%ensure-notebook-child notebook page) widget)
f36ca6af 1847 (expand boolean)
1848 (fill boolean)
1849 (pack-type pack-type))
1850
560af5c5 1851
1852
d520140e 1853;;; Paned
560af5c5 1854
bbaeff4b 1855(defbinding paned-pack1 () nil
d520140e 1856 (paned paned)
1857 (child widget)
1858 (resize boolean)
1859 (shrink boolean))
560af5c5 1860
bbaeff4b 1861(defbinding paned-pack2 () nil
d520140e 1862 (paned paned)
1863 (child widget)
1864 (resize boolean)
1865 (shrink boolean))
560af5c5 1866
560af5c5 1867
d520140e 1868;;; Layout
560af5c5 1869
bbaeff4b 1870(defbinding layout-put () nil
d520140e 1871 (layout layout)
68f519e0 1872 (child widget)
d520140e 1873 (x int)
1874 (y int))
560af5c5 1875
bbaeff4b 1876(defbinding layout-move () nil
d520140e 1877 (layout layout)
68f519e0 1878 (child widget)
d520140e 1879 (x int)
1880 (y int))
560af5c5 1881
68f519e0 1882(defbinding layout-set-size () nil
1883 (layout layout)
1884 (width unsigned-int)
1885 (height unsigned-int))
1886
1887(defbinding layout-get-size () nil
1888 (layout layout)
1889 (width unsigned-int :out)
1890 (height unsigned-int :out))
560af5c5 1891
1892
560af5c5 1893;;; Menu shell
1894
f5b67f2b 1895(defbinding menu-shell-insert (menu-shell menu-item position) nil
f36ca6af 1896 (menu-shell menu-shell)
1897 (menu-item menu-item)
f5b67f2b 1898 ((case position
1899 (:first 0)
1900 (:last -1)
1901 (t position)) int))
560af5c5 1902
f36ca6af 1903(defun menu-shell-append (menu-shell menu-item)
f5b67f2b 1904 (menu-shell-insert menu-shell menu-item :last))
560af5c5 1905
f36ca6af 1906(defun menu-shell-prepend (menu-shell menu-item)
f5b67f2b 1907 (menu-shell-insert menu-shell menu-item :fisrt))
560af5c5 1908
bbaeff4b 1909(defbinding menu-shell-deactivate () nil
f36ca6af 1910 (menu-shell menu-shell))
560af5c5 1911
bbaeff4b 1912(defbinding menu-shell-select-item () nil
f36ca6af 1913 (menu-shell menu-shell)
1914 (menu-item menu-item))
560af5c5 1915
d76e9fca 1916(defbinding menu-shell-select-first () nil
1917 (menu-shell menu-shell)
1918 (search-sensitive boolean))
1919
bbaeff4b 1920(defbinding menu-shell-deselect () nil
f36ca6af 1921 (menu-shell menu-shell))
560af5c5 1922
bbaeff4b 1923(defbinding menu-shell-activate-item () nil
f36ca6af 1924 (menu-shell menu-shell)
1925 (menu-item menu-item)
1926 (fore-deactivate boolean))
560af5c5 1927
d76e9fca 1928(defbinding menu-shell-cancel () nil
1929 (menu-shell menu-shell))
560af5c5 1930
1931
f5b67f2b 1932;;; Menu
560af5c5 1933
f5b67f2b 1934(defun %menu-position (menu child)
1935 (etypecase child
1936 (int child)
1937 (keyword (case child
1938 (:first 0)
1939 (:last -1)
1047e159 1940 (t (error "Invalid position keyword: ~A" child))))
f5b67f2b 1941 (widget (menu-child-position menu child))))
560af5c5 1942
1943
f5b67f2b 1944(defbinding menu-reorder-child (menu menu-item position) nil
1945 (menu menu)
1946 (menu-item menu-item)
1947 ((%menu-position menu position) int))
560af5c5 1948
d76e9fca 1949(defbinding menu-attach () nil
1950 (menu menu)
1951 (menu-item menu-item)
1952 (left-attach unsigned-int)
1953 (right-attach unsigned-int)
1954 (top-attach unsigned-int)
1955 (bottom-attach unsigned-int))
1956
56ccd5b7 1957(define-callback-marshal %menu-position-callback nil
1958 (menu (x int) (y int) (push-in boolean)))
560af5c5 1959
f5b67f2b 1960(defbinding %menu-popup () nil
1961 (menu menu)
1962 (parent-menu-shell (or null menu-shell))
1963 (parent-menu-item (or null menu-item))
56ccd5b7 1964 (callback (or null callback))
f5b67f2b 1965 (callback-id unsigned-int)
1966 (button unsigned-int)
1967 (activate-time (unsigned 32)))
1968
1969(defun menu-popup (menu button activate-time &key callback parent-menu-shell
1970 parent-menu-item)
1971 (if callback
1a1949c7 1972 (with-callback-function (id callback)
1973 (%menu-popup
1974 menu parent-menu-shell parent-menu-item
56ccd5b7 1975 %menu-position-callback id button activate-time))
f5b67f2b 1976 (%menu-popup
1977 menu parent-menu-shell parent-menu-item nil 0 button activate-time)))
1978
1979(defbinding menu-set-accel-path () nil
1980 (menu menu)
1981 (accel-path string))
560af5c5 1982
bbaeff4b 1983(defbinding menu-reposition () nil
f36ca6af 1984 (menu menu))
560af5c5 1985
bbaeff4b 1986(defbinding menu-popdown () nil
f36ca6af 1987 (menu menu))
560af5c5 1988
f5b67f2b 1989(defun menu-child-position (menu child)
1990 (position child (container-children menu)))
1991
1992(defun menu-active-num (menu)
1993 (menu-child-position menu (menu-active menu)))
1994
bbaeff4b 1995(defbinding %menu-set-active () nil
f36ca6af 1996 (menu menu)
1997 (index unsigned-int))
560af5c5 1998
f5b67f2b 1999(defun (setf menu-active) (menu child)
2000 (%menu-set-active menu (%menu-position menu child))
2001 child)
d520140e 2002
56ccd5b7 2003(define-callback %menu-detach-callback nil ((widget widget) (menu menu))
8ab0db90 2004 (funcall (user-data menu 'detach-func) widget menu))
d76e9fca 2005
5a87235c 2006(defbinding %menu-attach-to-widget (menu widget) nil
d76e9fca 2007 (menu menu)
2008 (widget widget)
56ccd5b7 2009 (%menu-detach-callback callback))
d76e9fca 2010
2011(defun menu-attach-to-widget (menu widget function)
8ab0db90 2012 (setf (user-data menu 'detach-func) function)
d76e9fca 2013 (%menu-attach-to-widget menu widget))
2014
2015(defbinding menu-detach () nil
2016 (menu menu))
2017
8ab0db90 2018#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
d76e9fca 2019(defbinding menu-get-for-attach-widget () (copy-of (glist widget))
2020 (widget widget))
2021
2022(defbinding menu-set-monitor () nil
2023 (menu menu)
2024 (monitor-num int))
560af5c5 2025
2026
f36ca6af 2027;;; Table
560af5c5 2028
bbaeff4b 2029(defbinding table-resize () nil
f36ca6af 2030 (table table)
2031 (rows unsigned-int)
2032 (columns unsigned-int))
560af5c5 2033
bbaeff4b 2034(defbinding table-attach (table child left right top bottom
c49be931 2035 &key options x-options y-options
2036 (x-padding 0) (y-padding 0)) nil
f36ca6af 2037 (table table)
2038 (child widget)
2039 (left unsigned-int)
2040 (right unsigned-int)
2041 (top unsigned-int)
2042 (bottom unsigned-int)
c49be931 2043 ((append (mklist options) (mklist x-options)) attach-options)
2044 ((append (mklist options) (mklist y-options)) attach-options)
f36ca6af 2045 (x-padding unsigned-int)
2046 (y-padding unsigned-int))
2047
e5b416f0 2048
bbaeff4b 2049(defbinding %table-set-row-spacing () nil
f36ca6af 2050 (table table)
2051 (row unsigned-int)
2052 (spacing unsigned-int))
2053
e5b416f0 2054(defbinding %table-set-row-spacings () nil
2055 (table table)
2056 (spacing unsigned-int))
2057
2058(defun (setf table-row-spacing) (spacing table &optional row)
2059 (if row
2060 (%table-set-row-spacing table row spacing)
2061 (%table-set-row-spacings table spacing))
f36ca6af 2062 spacing)
2063
e5b416f0 2064(defbinding %table-get-row-spacing () unsigned-int
f36ca6af 2065 (table table)
e5b416f0 2066 (row unsigned-int))
2067
2068(defbinding %table-get-default-row-spacing () unsigned-int
2069 (table table))
2070
2071(defun table-row-spacing (table &optional row)
2072 (if row
2073 (%table-get-row-spacing table row)
2074 (%table-get-default-row-spacing table)))
2075
f36ca6af 2076
bbaeff4b 2077(defbinding %table-set-col-spacing () nil
f36ca6af 2078 (table table)
2079 (col unsigned-int)
2080 (spacing unsigned-int))
2081
e5b416f0 2082(defbinding %table-set-col-spacings () nil
2083 (table table)
2084 (spacing unsigned-int))
2085
e3cdfeea 2086(defun (setf table-column-spacing) (spacing table &optional column)
2087 (if column
2088 (%table-set-col-spacing table column spacing)
e5b416f0 2089 (%table-set-col-spacings table spacing))
f36ca6af 2090 spacing)
2091
e3cdfeea 2092(defun (setf table-col-spacing) (spacing table &optional col)
2093 (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
2094 (setf (table-column-spacing table col) spacing))
2095
e5b416f0 2096(defbinding %table-get-col-spacing () unsigned-int
f36ca6af 2097 (table table)
e5b416f0 2098 (col unsigned-int))
2099
2100(defbinding %table-get-default-col-spacing () unsigned-int
2101 (table table))
2102
e3cdfeea 2103(defun table-column-spacing (table &optional column)
2104 (if column
2105 (%table-get-col-spacing table column)
e5b416f0 2106 (%table-get-default-col-spacing table)))
2107
e3cdfeea 2108(defun table-col-spacing (table &optional col)
2109 (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
2110 (table-column-spacing table col))
2111
e5b416f0 2112
f36ca6af 2113
2114;;; Toolbar
2115
cb4bf772 2116(defmethod initialize-instance ((toolbar toolbar) &rest initargs &key tooltips)
2117 (if (eq tooltips t)
2118 (apply #'call-next-method toolbar
2119 :tooltips (make-instance 'tooltips) initargs)
2120 (call-next-method)))
560af5c5 2121
cb4bf772 2122(defbinding %toolbar-insert () nil
f5b67f2b 2123 (toolbar toolbar)
cb4bf772 2124 (tool-item tool-item)
2125 (position position))
f36ca6af 2126
cb4bf772 2127(defun toolbar-insert (toolbar tool-item &optional (position :end))
2128 (%toolbar-insert toolbar tool-item position)
2129 (%tool-item-update-tooltips tool-item))
f5b67f2b 2130
cb4bf772 2131(defbinding toolbar-get-item-index () int
2132 (toolbar toolbar)
2133 (item tool-item))
f36ca6af 2134
cb4bf772 2135(defbinding toolbar-get-nth-item () tool-item
2136 (toolbar toolbar)
2137 (n int))
f36ca6af 2138
cb4bf772 2139(defbinding toolbar-get-drop-index () int
2140 (toolbar toolbar)
2141 (x int) (y int))
f36ca6af 2142
cb4bf772 2143(defbinding toolbar-set-drop-highlight-item () nil
2144 (toolbar toolbar)
2145 (tool-item tool-item)
2146 (index int))
f36ca6af 2147
560af5c5 2148
cb4bf772 2149;;; Tool button
560af5c5 2150
cb4bf772 2151(defmethod initialize-instance ((button tool-button) &rest initargs &key icon)
2152 (if (and icon (not (typep icon 'widget)))
2153 (apply #'call-next-method button :icon (create-image-widget icon) initargs)
2154 (call-next-method)))
560af5c5 2155
2156
cb4bf772 2157;;; Tool item
560af5c5 2158
cb4bf772 2159(defbinding tool-item-set-tooltip () nil
2160 (tool-item tool-item)
2161 (tooltips tooltips)
2162 (tip-text string)
2163 (tip-private string))
560af5c5 2164
560af5c5 2165
cb4bf772 2166(defun %tool-item-update-tooltips (tool-item)
2167 (when (and
2168 (slot-boundp tool-item 'parent)
2169 (or
2170 (user-data-p tool-item 'tip-text)
2171 (user-data-p tool-item 'tip-private)))
2172 (tool-item-set-tooltip
2173 tool-item (toolbar-tooltips (widget-parent tool-item))
2174 (or (user-data tool-item 'tip-text) "")
2175 (or (user-data tool-item 'tip-private) ""))))
2176
2177(defmethod (setf tool-item-tip-text) ((tip-text string) (tool-item tool-item))
2178 (setf (user-data tool-item 'tip-text) tip-text)
2179 (%tool-item-update-tooltips tool-item)
2180 tip-text)
2181
2182(defmethod (setf tool-item-tip-private) ((tip-private string) (tool-item tool-item))
2183 (setf (user-data tool-item 'tip-private) tip-private)
2184 (%tool-item-update-tooltips tool-item)
2185 tip-private)
2186
2187(defmethod container-add ((toolbar toolbar) (tool-item tool-item) &rest args)
2188 (declare (ignore args))
2189 (prog1
2190 (call-next-method)
2191 (%tool-item-update-tooltips tool-item)))
560af5c5 2192
d76e9fca 2193
2194(defbinding tool-item-retrieve-proxy-menu-item () widget
2195 (tool-item tool-item))
2196
2197(defbinding (tool-item-proxy-menu-item
2198 "gtk_tool_item_get_proxy_menu_item") () menu-item
2199 (tool-item tool-item)
2200 (menu-item-id string))
2201
2202(defbinding %tool-item-set-proxy-menu-item () nil
2203 (tool-item tool-item)
2204 (menu-item-id string)
2205 (menu-item menu-item))
2206
2207(defun (setf tool-item-proxy-menu-item) (menu-item menu-item-id tool-item)
2208 (%tool-item-set-proxy-menu-item menu-item-id tool-item menu-item)
2209 menu-item)
2210
8ab0db90 2211#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
d76e9fca 2212(defbinding tool-item-rebuild-menu () nil
2213 (tool-item tool-item))
2214
2215
bbaeff4b 2216;;; Editable
1047e159 2217
bbaeff4b 2218(defbinding editable-select-region (editable &optional (start 0) end) nil
f36ca6af 2219 (editable editable)
2220 (start int)
2221 ((or end -1) int))
560af5c5 2222
1047e159 2223(defbinding editable-get-selection-bounds (editable) nil
2224 (editable editable)
2225 (start int :out)
2226 (end int :out))
2227
d76e9fca 2228(defbinding editable-insert-text (editable text &optional (position 0)) nil
f36ca6af 2229 (editable editable)
2230 (text string)
2231 ((length text) int)
8ab0db90 2232 (position position :in/out))
560af5c5 2233
f36ca6af 2234(defun editable-append-text (editable text)
2235 (editable-insert-text editable text nil))
560af5c5 2236
f36ca6af 2237(defun editable-prepend-text (editable text)
2238 (editable-insert-text editable text 0))
560af5c5 2239
bbaeff4b 2240(defbinding editable-delete-text (editable &optional (start 0) end) nil
f36ca6af 2241 (editable editable)
2242 (start int)
2243 ((or end -1) int))
560af5c5 2244
bbaeff4b 2245(defbinding (editable-text "gtk_editable_get_chars")
f36ca6af 2246 (editable &optional (start 0) end) string
2247 (editable editable)
2248 (start int)
2249 ((or end -1) int))
560af5c5 2250
f36ca6af 2251(defun (setf editable-text) (text editable)
2252 (if text
2253 (editable-delete-text
2254 editable
2255 (editable-insert-text editable text))
2256 (editable-delete-text editable))
2257 text)
560af5c5 2258
bbaeff4b 2259(defbinding editable-cut-clipboard () nil
f36ca6af 2260 (editable editable))
560af5c5 2261
bbaeff4b 2262(defbinding editable-copy-clipboard () nil
f36ca6af 2263 (editable editable))
560af5c5 2264
bbaeff4b 2265(defbinding editable-paste-clipboard () nil
f36ca6af 2266 (editable editable))
560af5c5 2267
bbaeff4b 2268(defbinding editable-delete-selection () nil
f36ca6af 2269 (editable editable))
560af5c5 2270
560af5c5 2271
560af5c5 2272
f36ca6af 2273;;; Spin button
560af5c5 2274
d76e9fca 2275(defbinding spin-button-configure () nil
2276 (spin-button spin-button)
2277 (adjustment adjustment)
2278 (climb-rate double-float)
2279 (digits unsigned-int))
2280
2281(defbinding spin-button-set-range () nil
2282 (spin-button spin-button)
2283 (min double-float)
2284 (max double-float))
2285
2286(defbinding spin-button-get-range () nil
2287 (spin-button spin-button)
2288 (min double-float :out)
2289 (max double-float :out))
2290
f36ca6af 2291(defun spin-button-value-as-int (spin-button)
2292 (round (spin-button-value spin-button)))
560af5c5 2293
510fbcc1 2294(defbinding %spin-button-spin () nil
f36ca6af 2295 (spin-button spin-button)
2296 (direction spin-type)
510fbcc1 2297 (increment double-float))
2298
2299(defun spin-button-spin (spin-button value)
2300 (etypecase value
2301 (real (%spin-button-spin spin-button :spin-user-defined value))
2302 (spin-type (%spin-button-spin spin-button value 0))))
2303
560af5c5 2304
bbaeff4b 2305(defbinding spin-button-update () nil
f36ca6af 2306 (spin-button spin-button))
560af5c5 2307
2308
2309
2310; ;;; Ruler
2311
bbaeff4b 2312(defbinding ruler-set-range () nil
f36ca6af 2313 (ruler ruler)
2314 (lower single-float)
2315 (upper single-float)
2316 (position single-float)
2317 (max-size single-float))
560af5c5 2318
68f519e0 2319(defbinding ruler-get-range () nil
2320 (ruler ruler)
2321 (lower single-float :out)
2322 (upper single-float :out)
2323 (position single-float :out)
2324 (max-size single-float :out))
560af5c5 2325
560af5c5 2326
560af5c5 2327
d520140e 2328;;; Range
560af5c5 2329
1047e159 2330(defun range-lower (range)
2331 (adjustment-lower (range-adjustment range)))
560af5c5 2332
1047e159 2333(defun range-upper (range)
2334 (adjustment-upper (range-adjustment range)))
560af5c5 2335
1047e159 2336(defun (setf range-lower) (value range)
2337 (setf (adjustment-lower (range-adjustment range)) value))
560af5c5 2338
1047e159 2339(defun (setf range-upper) (value range)
2340 (setf (adjustment-upper (range-adjustment range)) value))
560af5c5 2341
1047e159 2342(defun range-page-increment (range)
2343 (adjustment-page-increment (range-adjustment range)))
560af5c5 2344
1047e159 2345(defun range-step-increment (range)
2346 (adjustment-step-increment (range-adjustment range)))
560af5c5 2347
1047e159 2348(defun (setf range-page-increment) (value range)
2349 (setf (adjustment-page-increment (range-adjustment range)) value))
560af5c5 2350
1047e159 2351(defun (setf range-step-increment) (value range)
2352 (setf (adjustment-step-increment (range-adjustment range)) value))
560af5c5 2353
1047e159 2354(defbinding range-set-range () nil
d520140e 2355 (range range)
1047e159 2356 (lower double-float)
2357 (upper double-float))
560af5c5 2358
1047e159 2359(defbinding range-set-increments () nil
d520140e 2360 (range range)
1047e159 2361 (step double-float)
2362 (page double-float))
560af5c5 2363
560af5c5 2364
d520140e 2365;;; Scale
560af5c5 2366
68f519e0 2367(defbinding scale-get-layout-offsets () nil
2368 (scale scale)
2369 (x int :out)
2370 (y int :out))
560af5c5 2371
560af5c5 2372
d520140e 2373;;; Progress bar
560af5c5 2374
bbaeff4b 2375(defbinding progress-bar-pulse () nil
d520140e 2376 (progress-bar progress-bar))
560af5c5 2377
2378
c49be931 2379;;; Size group
2380
2381(defmethod initialize-instance ((size-group size-group) &rest initargs
2382 &key widget widgets)
2383 (declare (ignore widget widgets))
2384 (prog1
2385 (call-next-method)
2386 (initial-add size-group #'size-group-add-widget
2387 initargs :widget :widgets)))
2388
2389
2390(defbinding size-group-add-widget () nil
2391 (size-group size-group)
2392 (widget widget))
2393
2394(defbinding size-group-remove-widget () nil
2395 (size-group size-group)
2396 (widget widget))
2397
560af5c5 2398
f5b67f2b 2399;;; Stock items
2400
73d58e01 2401(defbinding %stock-item-copy () pointer
2402 (location pointer))
2403
2404(defbinding %stock-item-free () nil
2405 (location pointer))
f5b67f2b 2406
73d58e01 2407(defbinding stock-add (stock-item) nil
2408 (stock-item stock-item)
2409 (1 unsigned-int))
2410
2411(defbinding stock-list-ids () (gslist string))
2412
2413(defbinding %stock-lookup () boolean
2414 (stock-id string)
2415 (location pointer))
2416
2417(defun stock-lookup (stock-id)
8ab0db90 2418 (with-memory (stock-item (foreign-size (find-class 'stock-item)))
0c5f20d9 2419 (when (%stock-lookup stock-id stock-item)
2420 (ensure-proxy-instance 'stock-item (%stock-item-copy stock-item)))))
560af5c5 2421
8ab0db90 2422#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
0c5f20d9 2423(progn
2424 (define-callback-marshal %stock-translate-callback string ((path string)))
2425
2426 (defbinding (stock-set-translate-function "gtk_stock_set_translate_func")
2427 (domain function) nil
2428 (domain string)
2429 (%stock-translate-callback callback)
2430 ((register-callback-function function) unsigned-int)
2431 (user-data-destroy-callback callback)))
2432
2433
560af5c5 2434
2435;;; Tooltips
2436
bbaeff4b 2437(defbinding tooltips-enable () nil
d520140e 2438 (tooltips tooltips))
560af5c5 2439
bbaeff4b 2440(defbinding tooltips-disable () nil
d520140e 2441 (tooltips tooltips))
560af5c5 2442
e5b416f0 2443(defun (setf tooltips-enabled-p) (enable tooltips)
2444 (if enable
2445 (tooltips-enable tooltips)
2446 (tooltips-disable tooltips)))
2447
bbaeff4b 2448(defbinding tooltips-set-tip () nil
d520140e 2449 (tooltips tooltips)
2450 (widget widget)
2451 (tip-text string)
2452 (tip-private string))
560af5c5 2453
d76e9fca 2454(defbinding tooltips-data-get () tooltips-data
2455 (widget widget))
2456
bbaeff4b 2457(defbinding tooltips-force-window () nil
d520140e 2458 (tooltips tooltips))
560af5c5 2459
d76e9fca 2460(defbinding tooltips-get-info-from-tip-window () boolean
2461 (tip-window window)
2462 (tooltips tooltips :out)
2463 (current-widget widget :out))
560af5c5 2464
2465
c1c0746b 2466;;; Resource Files
560af5c5 2467
61f0bf53 2468(defbinding rc-get-style () style
2469 (widget widget))
2470
2471(defbinding rc-get-style-by-paths (&key path class-path class) style
2472 (path (or null string))
2473 (class-path (or null string))
2474 (class gtype))
560af5c5 2475
61f0bf53 2476(defbinding rc-parse () nil
2477 (filename pathname))
560af5c5 2478
bbaeff4b 2479(defbinding rc-parse-string () nil
d520140e 2480 (rc-string string))
560af5c5 2481
61f0bf53 2482(defbinding %rc-reparse-all () boolean)
560af5c5 2483
61f0bf53 2484(defbinding %rc-reparse-all-for-settings () boolean
2485 (settings settings)
2486 (force-load-p boolean))
2487
2488(defun rc-reparse-all (&optional setting force-load-p)
2489 (if setting
2490 (%rc-reparse-all-for-settings setting force-load-p)
2491 (%rc-reparse-all)))
2492
2493(defbinding rc-reset-styles () nil
2494 (settings settings))
2495
2496(defbinding rc-add-default-file () nil
2497 (filename pathname))
2498
2499(defbinding rc-get-default-files ()
2500 (copy-of (null-terminated-vector (copy-of string))))
2501
2502(defbinding rc-get-module-dir () string)
2503
2504(defbinding rc-get-im-module-path () string)
2505
2506(defbinding rc-get-im-module-file () string)
2507
2508(defbinding rc-get-theme-dir () string)
2509
2510
2511;;; Settings
2512
2513(defbinding (settings-get "gtk_settings_get_for_screen")
2514 (&optional (screen (gdk:display-get-default-screen))) settings
2515 (screen gdk:screen))
2516
2517
2518;;; Plug and Socket
2519
2520(defbinding socket-add-id () nil
2521 (socket socket)
2522 (id gdk:native-window))
2523
2524(defbinding %plug-new () pointer
2525 (id gdk:native-window))
2526
2527(defmethod allocate-foreign ((plug plug) &key id)
2528 (%plug-new (or id 0)))
4007604e 2529
2530
2531;;;; New stuff in Gtk+ 2.10
2532
2533;;; Link button
2534
2535#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
2536(progn
2537 (define-callback-marshal %link-button-uri-callback nil (link-button (link string)))
2538
2539 (defbinding link-button-set-uri-hook (function) pointer
2540 (%link-button-uri-callback callback)
2541 ((register-callback-function function) unsigned-int)
2542 (user-data-destroy-callback callback)))