X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/510fbcc122c6b84b75f21c70992011fe86c53826..906b440e0e0c31964cd556bcdd71ebfdfd254285:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 6cd1d0e..16b0e4d 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 1999-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtk.lisp,v 1.36 2005-02-25 23:58:56 espen Exp $ +;; $Id: gtk.lisp,v 1.42 2005-04-23 16:48:51 espen Exp $ (in-package "GTK") @@ -44,7 +49,7 @@ ;;;; Initalization -(defbinding (gtk-init "gtk_parse_args") () nil +(defbinding (gtk-init "gtk_parse_args") () boolean "Initializes the library without opening the display." (nil null) (nil null)) @@ -53,7 +58,8 @@ "Initializes the system and starts the event handling" (unless (gdk:display-get-default) (gdk:gdk-init) - (gtk-init) + (unless (gtk-init) + (error "Initialization of GTK+ failed.")) (prog1 (gdk:display-open display) (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all) @@ -62,6 +68,17 @@ (setq *max-event-to-usec* 1000)))) +;;; Misc + +(defbinding grab-add () nil + (widget widget)) + +(defbinding grab-get-current () widget) + +(defbinding grab-remove () nil + (widget widget)) + + ;;; About dialog #+gtk2.6 @@ -176,6 +193,8 @@ ;;; Accel map +;(defbinding (accel-map-init "_gtk_accel_map_init") () nil) + (defbinding %accel-map-add-entry () nil (path string) (key unsigned-int) @@ -841,6 +860,12 @@ ;;; Label +(defmethod shared-initialize ((label label) names &key pattern) + (declare (ignore names)) + (call-next-method) + (when pattern + (setf (label-pattern label) pattern))) + (defbinding label-get-layout-offsets () nil (label label) (x int :out) @@ -871,6 +896,25 @@ "Add BUTTON1 to the group which BUTTON2 belongs to." (%radio-button-set-group button1 (%radio-button-get-group button2))) +(defun %add-activate-callback (widget signal function object after) + (if object + (signal-connect widget signal + #'(lambda (object) + (when (slot-value widget 'active) + (funcall function object (slot-value widget 'value)))) + :object object :after after) + (signal-connect widget signal + #'(lambda () + (when (slot-value widget 'active) + (funcall function (slot-value widget 'value)))) + :after after))) + +(defmethod activate-radio-widget ((button radio-button)) + (signal-emit button 'clicked)) + +(defmethod add-activate-callback ((button radio-button) function &key object after) + (%add-activate-callback button 'clicked function object after)) + (defmethod initialize-instance ((button radio-button) &key group) (prog1 (call-next-method) @@ -949,15 +993,19 @@ ;;; Message dialog -(defmethod initialize-instance ((dialog message-dialog) &rest initargs - &key (type :info) (buttons :close) ; or :ok? - flags message parent) - (remf initargs :parent) +(defmethod initialize-instance ((dialog message-dialog) + &key (message-type :info) (buttons :close) + flags text #+gtk 2.6 secondary-text + transient-parent) (setf (slot-value dialog 'location) - (%message-dialog-new parent flags type buttons nil)) - (message-dialog-set-markup dialog message) - (apply #'call-next-method dialog initargs)) + (%message-dialog-new transient-parent flags message-type buttons)) + (when text + (message-dialog-set-markup dialog text)) + #+gtk2.6 + (when secondary-text + (message-dialog-format-secondary-markup dialog secondary-text)) + (call-next-method)) (defbinding %message-dialog-new () pointer @@ -965,14 +1013,7 @@ (flags dialog-flags) (type message-type) (buttons buttons-type) - (message (or null string))) - -(defbinding %message-dialog-new-with-markup () pointer - (parent (or null window)) - (flags dialog-flags) - (type message-type) - (buttons buttons-type) - (message string)) + (nil null)) (defbinding message-dialog-set-markup () nil (message-dialog message-dialog) @@ -999,10 +1040,16 @@ (radio-menu-item radio-menu-item) (group pointer)) +(defmethod activate-radio-widget ((item radio-menu-item)) + (menu-item-activate item)) + (defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item)) "Add ITEM1 to the group which ITEM2 belongs to." (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2))) +(defmethod add-activate-callback ((item radio-menu-item) function &key object after) + (%add-activate-callback item 'activate function object after)) + (defmethod initialize-instance ((item radio-menu-item) &key group) (prog1 (call-next-method) @@ -1020,22 +1067,14 @@ (radio-tool-button radio-tool-button) (group pointer)) +(defmethod activate-radio-widget ((button radio-tool-button)) + (signal-emit button 'clicked)) + (defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button)) "Add BUTTON1 to the group which BUTTON2 belongs to." (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2))) - -(defmethod add-activate-callback ((widget widget) function &key object after) - (if object - (signal-connect widget 'clicked - #'(lambda (object) - (when (slot-value widget 'active) - (funcall function object (slot-value widget 'value)))) - :object object :after after) - (signal-connect widget 'clicked - #'(lambda () - (when (slot-value widget 'active) - (funcall function (slot-value widget 'value)))) - :after after))) +(defmethod add-activate-callback ((button radio-tool-button) function &key object after) + (%add-activate-callback button 'clicked function object after)) (defmethod initialize-instance ((button radio-tool-button) &key group) (prog1 @@ -1336,12 +1375,12 @@ (scrolled-window scrolled-window) (child widget)) -(defmethod initialize-instance ((window scrolled-window) &rest initargs - &key policy) - (if policy - (apply #'call-next-method window - :vscrollbar-policy policy :hscrollbar-policy policy initargs) - (call-next-method))) +(defmethod shared-initialize ((window scrolled-window) names &key policy) + (declare (ignore names)) + (when policy + (setf (slot-value window 'hscrollbar-policy) policy) + (setf (slot-value window 'vscrollbar-policy) policy)) + (call-next-method)) ;;; Statusbar